VBA Snippets

Convert_CentimetersToPoints

Public Function Convert_CentimetersToPoints(ByVal sglPoints As Single) As Single
Const sPROCNAME As String = "Convert_CentimetersToPoints"

    On Error GoTo AnError
    Convert_CentimetersToPoints = sglPoints * 28.3464567

    Exit Sub
AnError:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Convert_InchesToPoints

Public Function Convert_InchesToPoints(ByVal sglPoints As Single) As Single
Const sPROCNAME As String = "Convert_InchesToPoints"

    On Error GoTo AnError
    Convert_InchesToPoints = sglPoints * 72

    Exit Sub
AnError:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Convert_PointsToCentimeters

Public Function Convert_PointsToCentimeters(ByVal sglPoints As Single) As Single
Const sPROCNAME As String = "Convert_PointsToCentimeters"

    On Error GoTo AnError
    Convert_PointsToCentimeters = sglPoints * 0.0352777778

   Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Convert_PointsToInches

Public Function Convert_PointsToInches(ByVal sglPoints As Single) As Single
Const sPROCNAME As String = "Convert_PointsToInches"

    On Error GoTo AnError
    Convert_PointsToInches = sglPoints * 0.0138888889

    Exit Sub
AnError:
    Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

Convert_Units

Public Function Convert_Units(ByVal sglOrigValue As Single, _
                              ByVal sCurrentUnit As String, _
                              ByVal sNewUnit As String) As Single

Dim sglNewValue As Single

   On Error GoTo AnError
    
    Select Case sNewUnit
        Case "Centimeters"
            Select Case sCurrentUnit
                Case "Centimeters"
                    sglNewValue = sglOrigValue
                Case "Inches"
                    sglNewValue = Convert_CentimetersToPoints(sglOrigValue)
                    sglNewValue = Convert_PointsToInches(sglNewValue)
                Case "Points"
                    sglNewValue = Convert_PointsToCentimeters(sglOrigValue)
                End Select
            
        Case "Inches"
            Select Case sCurrentUnit
                Case "Centimeters"
                    sglNewValue = Convert_InchesToPoints(sglOrigValue)
                    sglNewValue = Convert_PointsToCentimeters(sglNewValue)
                Case "Inches"
                    sglNewValue = sglOrigValue
                Case "Points"
                    sglNewValue = Convert_PointsToInches(sglOrigValue)
            End Select
                    
        Case "Points"
            Select Case sCurrentUnit
                Case "Centimeters"
                    sglNewValue = Convert_CentimetersToPoints(sglOrigValue)
                Case "Inches"
                    sglNewValue = Convert_InchesToPoints(sglOrigValue)
                Case "Points"
                    sglNewValue = sglOrigValue
            End Select
        
    End Select
    
    Convert_Units = sglNewValue
            
   Exit Function
AnError:
   Call Error_Handle(msMODULENAME, "Convert_Units", Err)
End Function

Measure_PixelsPerInch

Include API calls.

Public Function Measure_PixelsPerInch(lDirection As Long) As Long
Dim lDeskTopHandle As Long
Dim lDC As Long
Dim lpixels As Long
   On Error GoTo AnError
   lDeskTopHandle = GetDeskTopWindow
   lDC = GetDC(lDeskTopHandle)
   
   If (lDirection = UT_DIRECTION_HORIZ) Then
      Measure_PixelsPerInch = GetDeviceCaps(lDC, 88)
   Else
      Measure_PixelsPerInch = GetDeviceCaps(lDC, 90)
   End If
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Measure_PixelsPerInch", msMODULENAME, 1, 
        "return the number of pixels per inch for the current desktop window")   
End Function

Measure_PixelsToPoints

Returns the number of points for a given number of pixels.

Public Function Measure_PixelsToPoints(lNoOfPixels As Long, _
                               lDirection As Long) As Single
Dim sngPointsPerIch As Single
   On Error GoTo AnError
   sngPointsPerInch = Application.DefaultWebOptions.PixelsPerInch(lDirection)
   Measure_PixelsToPoints = Application.InchesToPoints(lNoOfPixels / sngPointsPerInch)
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Measure_PixelsToPoints", msMODULENAME, 1, _
        "return the number of points for the corresponding number of pixels")
End Function

Number_IsItInRange

Public Function Number_IsItInRange(vNumber As Variant, _
                                   vTopBracket As Variant, _
                                   vBottomBracket As Variant, _
                                   Optional bEqualTo As Boolean = True) As Boolean
   On Error GoTo AnError
   If bEqualTo = True Then
      If (vNumber >= vTopBracket) And (vNumber <= vBottomBracket) Then
         Number_IsItInRange = True
      Else: Number_IsItInRange = False
      End If
   Else
      If (vNumber > vTopBracket) And (vNumber < vBottomBracket) Then
         Number_IsItInRange = True
      Else: Number_IsItInRange = False
      End If
   End If
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Number_IsItInRange", msMODULENAME, 1, _
        "determine if the number """ & vNumber & """ is in the range between" & _
        " """ & vBottomBracket & """ to """ & vTopBracket & """ or not")
End Function

Number_IsNumber

Public Function IsNumber(ByVal Value As String) As Boolean

Dim DP As String
Dim TS As String
' Get local setting for decimal point
DP = Format$(0, ".")
    
    On Error GoTo AnError
    
    ' Get local setting for thousand's separator and eliminate them. Remove the next two lines
    ' if you don't want your users being able to  type in the thousands separator at all.

    TS = Mid$(Format$(1000, "#,###"), 2, 1)
    Value = Replace$(Value, TS, "")

    ' Leave the next statement out if you don't
    ' want to provide for plus/minus signs

    If Value Like "[+-]*" Then Value = Mid$(Value, 2)

    IsNumber = Not Value Like "*[!0-9" & DP & "]*" And 
               Not Value Like "*" & DP & "*" & DP & "*" And _
               Len(Value) > 0 And Value <> DP And _
               Value <> vbNullString
    
   Exit Function
AnError:
   Call Error_Handle(msMODULENAME, "IsNumber", Err)
End Function

Number_Random

Public Function Number_Random(ByVal dbLowestValue As Double, _
                              ByVal dbHighestValue As Double, _
                     Optional ByVal iNoOfDecimals As Integer) As Double
                    
   Application.Volatile  'Remove this line to "freeze" the numbers
   
   If IsMissing(iNoOfDecimals) Or iNoOfDecimals = 0 Then
      Call VBA.Randomize
      Number_Random = VBA.Int((dbHighestValue + 1 - dbLowestValue) * VBA.Rnd + dbLowestValue)
   Else
      Call VBA.Randomize
      Number_Random = VBA.Round((dbHighestValue - dbLowestValue) * VBA.Rnd + dbLowestValue, iNoOfDecimals)
   End If
   
End Function

Number_ReturnPowerOfTen

Public Function Number_ReturnPowerOfTen(sngNumber As Single) As Integer
   On Error GoTo AnError
'power of ten to multiple with for range 10 < 100
   sngNumber = sngNumber * 1.0001      'to compensate for 9.999973563636 etc
   If (0 < sngNumber) And (sngNumber < 0.0000001) Then Number_ReturnPowerOfTen = 9
   If (0.0000001 < sngNumber) And (sngNumber < 0.000001) Then Number_ReturnPowerOfTen = 8
   If (0.000001 <= sngNumber) And (sngNumber < 0.00001) Then Number_ReturnPowerOfTen = 7
   If (0.00001 <= sngNumber) And (sngNumber < 0.0001) Then Number_ReturnPowerOfTen = 6
   If (0.0001 <= sngNumber) And (sngNumber < 0.001) Then Number_ReturnPowerOfTen = 5
   If (0.001 <= sngNumber) And (sngNumber < 0.01) Then Number_ReturnPowerOfTen = 4
   If (0.01 <= sngNumber) And (sngNumber < 0.1) Then Number_ReturnPowerOfTen = 3
   If (0.1 <= sngNumber) And (sngNumber < 1) Then Number_ReturnPowerOfTen = 2
   If (1 <= sngNumber) And (sngNumber < 10) Then Number_ReturnPowerOfTen = 1
   If (10 <= sngNumber) And (sngNumber < 100) Then Number_ReturnPowerOfTen = 0
   If (100 <= sngNumber) And (sngNumber < 1000) Then Number_ReturnPowerOfTen = -1
   If (1000 <= sngNumber) And (sngNumber < 10000) Then Number_ReturnPowerOfTen = -2
   If (10000 <= sngNumber) And (sngNumber < 100000) Then Number_ReturnPowerOfTen = -3
   If (100000 <= sngNumber) And (sngNumber < 1000000) Then Number_ReturnPowerOfTen = -4
   If (1000000 <= sngNumber) And (sngNumber < 10000000) Then Number_ReturnPowerOfTen = -5
   If (10000000 <= sngNumber) Then Number_ReturnPowerOfTen = -6
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Number_ReturnPowerOfTen", msMODULENAME, 1, _
        "return to what power of ten the number """ & sngNumber &""" is")
End Function

Number_RoundUp

Public Function Number_RoundUp( _
   ByVal dblNumToRound As Double, _
   ByVal lMultiple As Long) As Double
   
    Dim asDec   As Variant
    Dim rounded As Variant

    asDec = CDec(dblNumToRound) / lMultiple
    rounded = Int(asDec)

    If rounded <> asDec Then
       rounded = rounded + 1
    End If
    Number_RoundUp = rounded * lMultiple
End Function

Number_TenToThePowerOf

Public Function Number_TenToThePowerOf(iMultiple As Integer) As Single
Dim icount As Integer
Dim lpowersoften As Long
   On Error GoTo AnError
   lpowersoften = 1
   If Abs(iMultiple) = 0 Then           'if modulus is zero then no power of ten multiple
      lpowersoften = 1
   Else
      For icount = 1 To Abs(iMultiple)
         lpowersoften = 10 * lpowersoften                  'obtains power of ten multiple
      Next icount
   End If
   If iMultiple <= 0 Then Number_TenToThePowerOf = 1 / lpowersoften
                                                              'if negative divide (10E-3)
   If iMultiple > 0 Then Number_TenToThePowerOf = lpowersoften
                                                                'if positive just (10E+3)
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Number_TenToThePowerOf", msMODULENAME, 1, _
        "return 10 to the power of """ & iMultiple & """")
End Function

Numbers_LargestOne

Returns the largest number out of all those passed in through an array.

Public Function Numbers_LargestOne(ParamArray vNumbers() As Variant) As Double
Dim vNumber As Variant
Dim dlargest As Double
   On Error GoTo AnError
   dlargest = vNumbers(0)
   For Each vNumber In vNumbers
      If vNumber > dlargest Then dlargest = vNumber
   Next vNumber
   Numbers_LargestOne = dlargest
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Numbers_LargestOne", msMODULENAME, 1, _
        "return the largest number from all those passed in")
End Function

Numbers_SmallestOne

Returns the smallest number out of all those passed in through an array.

Public Function Numbers_SmallestOne(ParamArray vNumbers() As Variant) As Double
Dim vNumber As Variant
Dim dsmallest As Double
   On Error GoTo AnError
   dsmallest = vNumbers(0)
   For Each vNumber In vNumbers
      If vNumber < dsmallest Then dsmallest = vNumber
   Next vNumber
   Numbers_SmallestOne = dsmallest
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Numbers_SmallestOne", msMODULENAME, 1, _
        "return the smallest number from all those passed in")
End Function