Visual Basic for Applications/Print version

From Wikibooks, open books for an open world
Jump to navigation Jump to search


Visual Basic for Applications

The current, editable version of this book is available in Wikibooks, the open-content textbooks collection, at
https://en.wikibooks.org/wiki/Visual_Basic_for_Applications

Permission is granted to copy, distribute, and/or modify this document under the terms of the Creative Commons Attribution-ShareAlike 3.0 License.

Contents


Character 1D Arrays

Summary[edit]

  • This VBA code module is intended for any Microsoft Office application that supports VBA.
  • It allows strings to be loaded into one-dimensional arrays one character per element, and to join such array characters into single strings again.
  • The module is useful in splitting the characters of a single word ,something that the Split method cannot handle.

Notes on the code[edit]

Copy all of the procedures below into a VBA standard module, save the workbook as a xlsm type, then run the top procedure to show that the process is accurate.

The VBA Code Module[edit]

Sub testStrTo1DArr()
    ' run this to test array string load
    ' and array to string remake procedures
    
    Dim vR As Variant, vE As Variant
    Dim sStr As String, bOK As Boolean, sOut As String
    
    sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    
    'split string into array elements
    bOK = StrTo1DArr(sStr, vR, False)
    
    If bOK = True Then
        'optional array transfer
        vE = vR
        
        'remake string from array
        sOut = Arr1DToStr(vE)
        
        'show that output = input
        MsgBox sStr & vbCrLf & sOut
    Else
        Exit Sub
    End If

End Sub

Function StrTo1DArr(ByVal sIn As String, vRet As Variant, _
                    Optional ByVal bLB1 As Boolean = True) As Boolean
    ' Loads string characters into 1D array (vRet). One per element.
    ' Optional choice of lower bound. bLB1 = True for one-based (default),
    ' else bLB1 = False for zero-based. vRet dimensioned in proc.

    Dim nC As Long, sT As String
    Dim LB As Long, UB As Long
    
    If sIn = "" Then
        MsgBox "Empty string - closing"
        Exit Function
    End If
    
    'allocate array for chosen lower bound
    If bLB1 = True Then
        ReDim vRet(1 To Len(sIn))
    Else
        ReDim vRet(0 To Len(sIn) - 1)
    End If
    LB = LBound(vRet): UB = UBound(vRet)

    'load charas of string into array
    For nC = LB To UB
        If bLB1 = True Then
            sT = Mid$(sIn, nC, 1)
        Else
            sT = Mid$(sIn, nC + 1, 1)
        End If
        vRet(nC) = sT
    Next

    StrTo1DArr = True

End Function
    
Function Arr1DToStr(vIn As Variant) As String
    ' Makes a single string from 1D array string elements.
    ' Works for any array bounds.
        
    Dim nC As Long, sT As String, sAccum As String
    Dim LB As Long, UB As Long
    
    LB = LBound(vIn): UB = UBound(vIn)

    'join characters of array into string
    For nC = LB To UB
        sT = vIn(nC)
        sAccum = sAccum & sT
    Next

    Arr1DToStr = sAccum

End Function

See Also[edit]

External Links[edit]



Array Data To Immediate Window

Summary[edit]

This VBA code module allows the listing of arrays in the immediate window. It makes use of various procedures that fill the array for demonstration and testing. The VBA code runs in MS Excel but is easily adapted for any of the MS Office products that run VBA.

Code Notes[edit]

  • DispArrInImmWindow() is the main procedure. It formats and prints data found on the two dimensional input array. It prints on the VBA Editor's Immediate Window. Options include the printing of data as found or making use of decimal rounding and alignment. The entire output print is also available as a string for external use. The process depends on monospaced fonts being set for any display, including the VBA editor.
  • RndAlphaToArr(), RndNumericToArr(), and RndMixedDataToArr() load an array with random data. The data is random in the content and length of elements, but in addition, numerics have random integer and decimal parts. Each allows adjustment of options internally to accommodate personal preferences.
  • TabularAlignTxtOrNum() is not used in this demonstration. It is included for those who prefer to format each individual column of an array during the loading process. Its input variant takes a single string or number and returns the formatted result in a user-set fixed field width. The number of decimal places of rounding can be set. Note that when all data in a column of a numeric array is loaded with the same parameters, the result is always decimal point alignment.
  • WriteToFile() is a monospaced font, text file-making procedure. If the file name does not exist, it will be made and saved automatically. Each save of text will completely replace any previously added. It is added here in case a user needs to save an output greater than that possible for the Immediate Window. The Immediate Window is limited to about two hundred lines of code, so large arrays should make use of the main procedure's sOut string. Again, wherever outputs from the main procedure are used, monospaced fonts are assumed.

The VBA Module[edit]

Copy the entire code module into a standard VBA module, save the file as type .xlsm and run the top procedure. Be sure to set monospaced fonts for the VBA editor or the object will have been defeated.

Updates[edit]

  • 26 Nov 2019: Adjusted DispArrInImmWindow() code to better estimate maximum column width, taking account of imposed decimal places.
Option Explicit

Private Sub testDispArrInImmWindow()
    'Run this to display a selection of data arrays
    'in the immediate window. Auto formatting
    'includes rounding and decimal point alignment.
    'Alternative is to print data untouched.
    'SET IMMEDIATE WINDOW FONT TO MONOSPACED
    'Eg: Consolas or Courier.
    
    Dim vArr As Variant, vArr2 As Variant, sOutput As String
     
    'clear the immediate window
    ClearImmWindow
    
    'UNFORMATTED random length alpha strings
    RndAlphaToArr vArr, 5, 6        'length setting made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random length alpha strings
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2
    
    
    'UNFORMATTED random length numbers and decimals
    RndNumericToArr vArr, 5, 6      'various settings made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random length numbers and decimals
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2
    
        
    'UNFORMATTED random alpha and number alternating columns
    RndMixedDataToArr vArr, 5, 6    'various settings made in proc
    vArr2 = vArr
    Debug.Print "UNFORMATTED"
    DispArrInImmWindow vArr, False, 2
    'FORMATTED random alpha and number alternating columns
    Debug.Print "FORMATTED"
    DispArrInImmWindow vArr2, True, 2, sOutput
    
    'output whole string version to a log file
    'WriteToFile sOutput, ThisWorkbook.Path & "\MyLongArray.txt"

End Sub

Private Sub ClearImmWindow()
    
    'NOTES
    'Clears VBA immediate window down to the insertion point,
    'but not beyond. Not a problem as long as cursor is
    'at end of text, but otherwise not.
    'Clear manually before any neat work.
    'Manual clear method: Ctrl-G then Ctrl-A then Delete.
    
    'Max display in immediate window is 199 lines,
    'then top lines are lost as new ones added at bottom.
    'No reliable code method exists.
    
    Debug.Print String(200, vbCrLf)
    
End Sub

Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
                                  Optional ByVal nNumDecs As Integer = 2, _
                                     Optional sOut As String)

    '--------------------------------------------------------------------------
    'vA :               Input 2D array for display in the immediate window.
    'sOut:              Alternative formatted output string.
    'bFormatAlignData : True: applies decimal rounding and decimal alignment,
    '                   False: data untouched with only basic column spacing.
    'nNumDecs:          Sets the rounding up and down of decimal places.
    '                   Integers do not have zeros added at any time.
    'Clear the immediate window before each run for best results.
    'The immediate window at best lists 199 lines before overwrite, so
    'consider using sOut for large arrays.  'ie; use it in a text file
    'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
    'so set the font VBA editor or any textbox to Courier or Consolas.
    'To set different formats for EVERY column of an array it is best to add
    'the formats at loading time with the procedure TabularAlignTxtOrNumber().
    '--------------------------------------------------------------------------
    
    'messy when integers are set in array and decimals is set say to 3.
    'maybe the measurement of max element width should include a measure
    ' for any dot or extra imposed decimal places as well
    'different for integers and for existing decimals
        
    Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
    Dim sPadding As String, sDecFormat As String, sR As String, sE As String
    Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
    Dim nMaxFieldWidth As Integer, bSkip As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    'get bounds of input array
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
    
    ReDim vD(LB1 To UB1, LB2 To UB2) 'display
    ReDim vC(LB2 To UB2)             'column max
    
    '--------------------------------------
    'set distance between fixed width
    'fields in the output display
    nInterFieldSpace = 3
    'not now used
    nMaxFieldWidth = 14
    '--------------------------------------
    
    If nNumDecs < 0 Then
        MsgBox "nNumDecs parameter must not be negative - closing"
        Exit Sub
    End If
        
    'find widest element in each column
    'and adjust it for any imposed decimal places
    For c = LB2 To UB2
        n = 0: m = 0
        For r = LB1 To UB1
            'get element length
            If IsNumeric(vA(r, c)) Then
                If Int(vA(r, c)) = vA(r, c) Then 'is integer
                    n = Len(vA(r, c)) + 1 + nNumDecs
                Else 'is not integer
                    If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
                        n = Len(vA(r, c))
                    Else  'add the difference in length as result of imposed decimal places
                        n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
                    End If
                End If
            Else
                n = Len(vA(r, c))
            End If
            
            If n > m Then m = n 'update if longer
        Next r
        'store the maximum length
        'of data in each column
        vC(c) = m
    Next c
        
    For c = LB2 To UB2
        For r = LB1 To UB1
            sE = Trim(vA(r, c))

            If bFormatAlignData = False Then
                sDecFormat = sE
                nP = InStr(sE, ".")
                bSkip = True
            End If

            'make a basic format
            If bSkip = False Then
                nP = InStr(sE, ".")
                'numeric with a decimal point
                If IsNumeric(sE) = True And nP > 0 Then
                    sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
                'integer
                ElseIf IsNumeric(sE) = True And nP <= 0 Then
                    sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
                'alpha
                ElseIf IsNumeric(sE) = False Then
                    sDecFormat = sE
                End If
            End If
  
            'adjust field width to widest in column
            bSkip = False
            sPadding = Space$(vC(c))
            'numeric with a decimal point
            If IsNumeric(sE) = True And nP > 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'integer
            ElseIf IsNumeric(sE) = True And nP <= 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'alpha
            ElseIf IsNumeric(sE) = False Then
                vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
            End If
        Next r
    Next c
        
    'output
    sOut = ""
    For r = LB1 To UB1
        For c = LB2 To UB2
            sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
        Next c
        Debug.Print sR             'print one row in imm window
        sOut = sOut & sR & vbCrLf  'accum one row in output string
        sR = ""
    Next r
    sOut = sOut & vbCrLf
    Debug.Print vbCrLf

End Sub

Private Sub RndAlphaToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random string lengths
            
    Dim sT As String, sAccum As String, nMinLenStr As Integer
    Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
    Dim nAsc As Integer, r As Long, c As Long
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set minimum and maximum strings lengths here
    nMinLenStr = 2   'the minimum random text length
    nMaxLenStr = 8  'the maximum random text length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
            
            'make one random length string
            For n = 1 To nLenWord
                nAsc = Int((90 - 65 + 1) * Rnd + 65)
                sT = Chr$(nAsc)
                sAccum = sAccum & sT
            Next n
            
            'store string
            vIn(r, c) = sAccum
            sAccum = "": sT = ""
        Next c
    Next r

End Sub

Private Sub RndNumericToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random number lengths
    
    Dim sT1 As String, sT2 As String, nMinLenDec As Integer, sSign As String
    Dim sAccum1 As String, sAccum2 As String, nMaxLenDec As Integer
    Dim nLenInt As Integer, nLenDecs As Integer, nMinLenInt As Integer
    Dim n As Long, r As Long, c As Long, nAsc As Integer, nMaxLenInt As Integer
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
      
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenDec = 0   'the minumum decimal part length
    nMaxLenDec = 4   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 4   'the maximum integer part length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
            nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            'make one random length integer string
            For n = 1 To nLenInt
                    If nLenInt = 1 Then                      'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    ElseIf nLenInt <> 1 And n = 1 Then       'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    Else
                        nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
                    End If
                    
                    sT1 = Chr$(nAsc)
                    sAccum1 = sAccum1 & sT1
                Next n
            'make one random length decimal part
            For n = 0 To nLenDecs
                nAsc = Int((57 - 48 + 1) * Rnd + 48)
                sT2 = Chr$(nAsc)
                sAccum2 = sAccum2 & sT2
            Next n
            'decide whether or not a negative number
            nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
            If nAsc = 5 Then sSign = "-" Else sSign = ""
            
            'store string
            If nLenDecs <> 0 Then
                vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
            Else
                vIn(r, c) = CSng(sSign & sAccum1)
            End If
                    
            sT1 = "": sT2 = ""
            sAccum1 = "": sAccum2 = ""
            'MsgBox vIn(r, c)
        Next c
    Next r
End Sub

Private Sub RndMixedDataToArr(vIn As Variant, nRows As Integer, nCols As Integer)
    'loads a 2D array in place with random string lengths
    
    Dim sAccum As String, nMinLenStr As Integer, sSign As String
    Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
    Dim nAsc As Integer, r As Long, c As Long, nMaxLenDec As Integer
    Dim sT As String, sT1 As String, sT2 As String, nMinLenDec As Integer
    Dim sAccum1 As String, sAccum2 As String, nMinLenInt As Integer
    Dim nLenInt As Integer, nLenDecs As Integer, nMaxLenInt As Integer
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenStr = 3   'the minimum random text length
    nMaxLenStr = 8   'the maximum random text length
    nMinLenDec = 0   'the minumum decimal part length
    nMaxLenDec = 4   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 4   'the maximum integer part length
    '--------------------------------------------------
    
    Randomize
    For r = LB1 To UB1
        For c = LB2 To UB2
            If c Mod 2 <> 0 Then
                
                nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
                
                'make one random length string
                For n = 1 To nLenWord
                    nAsc = Int((90 - 65 + 1) * Rnd + 65)
                    sT = Chr$(nAsc)
                    sAccum = sAccum & sT
                Next n
                
                'store string
                vIn(r, c) = sAccum
                sAccum = "": sT = ""
            Else
                nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
                'make one random length integer string
                For n = 1 To nLenInt
                    If nLenInt = 1 Then                      'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    ElseIf nLenInt <> 1 And n = 1 Then       'exclude zero choice
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                    Else
                        nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
                    End If
                    
                    sT1 = Chr$(nAsc)
                    sAccum1 = sAccum1 & sT1
                Next n
                'make one random length decimal part
                If nLenDecs <> 0 Then
                    For n = 1 To nLenDecs
                        nAsc = Int((57 - 48 + 1) * Rnd + 48)
                        sT2 = Chr$(nAsc)
                        sAccum2 = sAccum2 & sT2
                    Next n
                Else
                        sAccum2 = ""
                End If
                'decide whether or not a negative number
                nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
                If nAsc = 5 Then sSign = "-" Else sSign = ""
                            
                'store string
                If nLenDecs <> 0 Then
                    vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
                Else
                    vIn(r, c) = CSng(sSign & sAccum1)
                End If
                        
                sT1 = "": sT2 = ""
                sAccum1 = "": sAccum2 = ""
            End If
        Next c
    Next r

End Sub

Sub testNumDecAlign()
    'produces examples in immediate window for single entries
    
    'clear the immediate window
    ClearImmWindow
    
    Debug.Print "|" & TabularAlignTxtOrNum(Cos(30), 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum("Text Heading", 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum(345.746453, 3, 12) & "|"
    Debug.Print "|" & TabularAlignTxtOrNum(56.5645, 0, 12) & "|"
    Debug.Print vbCrLf

End Sub

Private Function TabularAlignTxtOrNum(vIn As Variant, nNumDecs As Integer, _
                      nFieldWidth As Integer) As String
    'Notes:
    'Returns vIn in function name, formatted to given number of decimals,
    'and padded for display. VIn can contain an alpha string, a numeric
    'string, or a number. nNumDecs is intended number of decimals
    'in the output and nFieldWidth is its total padded width.
    'Non-numerics are left-aligned and numerics are right-aligned.
    'Decimal alignment results when say, all of an array column is
    'formatted with the same parameters.
    'ASSUMES THAT A MONOSPACED FONT WILL BE USED FOR DISPLAY
    
    Dim sPadding As String, sDecFormat As String
        
    'make a format based on whether numeric and how many decimals
    If IsNumeric(vIn) Then
        If nNumDecs > 0 Then                 'decimals
            sDecFormat = Format$(vIn, "0." & String$(nNumDecs, "0"))
        Else
            sDecFormat = Format$(vIn, "0") 'no decimals
        End If
    Else
            sDecFormat = vIn                 'non numeric
    End If
            
    'get a space string equal to max width
    sPadding = Space$(nFieldWidth)
    
    'combine and limit width
    If IsNumeric(vIn) Then
    'combine and limit width
        TabularAlignTxtOrNum = Right$(sPadding & sDecFormat, nFieldWidth)
    Else
        TabularAlignTxtOrNum = Left$(sDecFormat & sPadding, nFieldWidth)
    End If

End Function

Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

See Also[edit]



/Array Data To WorkSheet (1D or 2D)

Summary[edit]

This MS Excel VBA code listing transfers data from a one or two dimensional array to a worksheet.

Code Notes[edit]

  • Arr1Dor2DtoWorksheet() transfers data from an array to a specified worksheet, and at a specified location within it. It takes one-dimensional or two-dimensional arrays, and is able to distinguish between them, prior to the transfer. Non-array inputs are detected as are arrays that are not allocated. One-dimensional arrays are transferred into a sheet row in all cases. Two-dimensional arrays are displayed in the same row and column shape as in the array. There are no facilities in the procedure to transpose data, but procedures exist elsewhere in this series for that purpose.

The VBA Module[edit]

  • Copy the entire code listing into a VBA standard module and run the top procedure. Save the worksheet as type .xlsm. Comment and de-comment lines in the top procedure and adjust parameters to test the main procedure.
Sub TestArr1Dor2DtoWorksheet()

    Dim vB As Variant, vC As Variant, a() As String, sE As String
    Dim r As Long, c As Long, oSht As Worksheet
    
    'preliminaries
    Set oSht = ThisWorkbook.Worksheets("Sheet2")
    oSht.Activate
    oSht.Cells.Clear
    oSht.Cells(1, 1).Select
    
    'load a one dimensional array to test
    'vB = Array("a", "b", "c", "d") 'array and allocated one dimension
    vB = Split("A B C D E F G H I J K L M", " ")
    'load a two dimensional array to test
    ReDim vC(1 To 4, 1 To 4)
    For r = 1 To 3
        For c = 1 To 4
            vC(r, c) = CStr(r & "," & c)
        Next c
    Next r
    
    'Use these to test if input filters
    'Arr1Dor2DtoWorksheet sE, "Sheet2", 3, 3        'run to test not-an-array feature
    'Arr1Dor2DtoWorksheet a(), "Sheet2", 3, 3       'run to test not-allocated feature
    
    'print arrays on sheet
    Arr1Dor2DtoWorksheet vB, "Sheet2", 2, 2        '1D to sheet row
    Arr1Dor2DtoWorksheet vC, "Sheet2", 5, 2        '2D to sheet range

End Sub

Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
                         ByVal nRow As Long, ByVal nCol As Long) As Boolean
    
    'Transfers a one or two dimensioned input array vA to the worksheet,
    'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
    'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
            
    Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
    Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
    Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
    
    'CHECK THE INPUT ARRAY
    On Error Resume Next
        'is it an array
        If IsArray(vA) = False Then
            bProb = True
        End If
        'check if allocated
        nR = UBound(vA, 1)
        If Err.Number <> 0 Then
            bProb = True
        End If
    Err.Clear
        
    If bProb = False Then
        'count dimensions
        On Error Resume Next
        Do
            nD = nD + 1
            nR = UBound(vA, nD)
        Loop Until Err.Number <> 0
    Else
        MsgBox "Parameter is not an array" & _
        vbCrLf & "or is unallocated - closing."
        Exit Function
    End If
    'get number of dimensions
    Err.Clear
    nDim = nD - 1: 'MsgBox nDim

    'get ref to worksheet
    Set oSht = ThisWorkbook.Worksheets(sSht)
       
    'set a worksheet range for array
    Select Case nDim
    Case 1 'one dimensional array
        LBR = LBound(vA): UBR = UBound(vA)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
    Case 2 'two dimensional array
        LBR = LBound(vA, 1): UBR = UBound(vA, 1)
        LBC = LBound(vA, 2): UBC = UBound(vA, 2)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
    Case Else 'unable to print more dimensions
        MsgBox "Too many dimensions - closing"
        Exit Function
    End Select

    'transfer array values to worksheet
        rng.Value = vA
    
    'release object variables
    Set oSht = Nothing
    Set rng = Nothing
    
    'returns
    Arr1Dor2DtoWorksheet = True

End Function

See Also[edit]



Array Output Transfers

Summary[edit]

This VBA code module demonstrates four basic methods of array display. It is intended to run in MS Excel, though with the exception of the first method, transfer to the worksheet, it could be adapted easily for MS Word or other MS Office applications that run VBA.

Code Notes[edit]

  • The code first loads an array with selected random data. Then the entire array is transferred to the worksheet. The data is further formatted and displayed in the immediate window, in well spaced columns. An additional copy of the formatted output is passed to the clipboard for further external use, and it is also sent to a text file to illustrate the method.
  • RndDataToArr() can load an array with random data. The data types can be set as parameters, and further limits can be found within the procedure itself. Alpha, integer, decimal, dates, and mixed data are available, most random in both length and content.
  • Arr1Dor2DtoWorksheet() can transfer either a one-dimensional or two dimensional array to a worksheet. It can be positioned at any location. It checks that an array exists,that it is allocated, and its number of dimensions in setting the transfer range.
  • DispArrInImmWindow() formats and displays a 2D array in the immediate window of the VBA editor. It takes account of all data length in setting the well aligned columns. There are parameters to set maximum decimal places and the choice of decimal point alignment or raw data. The layout can handle mixed columns of text and numbers, though it has best appearance when all data of a column is of the same type. The whole array's formatted output is available as a single string for external use, useful for arrays beyond 199 rows, as too big for the immediate window.
  • CopyToClip() is used to pass a string to the clipboard. It is used here to upload the formatted array string. The clipboard will retain the contents only until the calling application (Excel) closes. It should be noted that other clipboard procedures in this series retain their content until the Windows platform closes.
  • GetFromClip() retrieves the contents of the clipboard. It is used here purely for demonstration. It passes the entire formatted string of the array to a text file.
  • WriteToFile() opens and writes to a named text file. It completely replaces any text that it already contains. If the file does not exist the procedure makes it, in the same directory as the Excel file itself.

The VBA Code Module[edit]

Copy the entire code listing into an Excel VBA module, and run the top procedure to test the four array transfer methods. Save the file as type xlsm. The code writes to Sheet1, and to the immediate window of the VBA editor. Further array listings will be found on the clipboard and in a text file made for the purpose.

Option Explicit
Private Sub ArrayOutputTests()
    ' Test procedure for array display
    '1 array to worksheet
    '2 formatted array to immediate window
    '3 formatted array to clipboard
    '4 formatted array to text file

    Dim vA As Variant, vB As Variant
    Dim sArr As String, oSht As Worksheet
    Dim sIn As String, sOut As String, sSheet As String
    
    '-------------------------------------------
    'choose worksheet for display
    '-------------------------------------------
    
        sSheet = "Sheet1"
        Set oSht = ThisWorkbook.Worksheets(sSheet)
    
    '-------------------------------------------
    'load an array to test
    '-------------------------------------------
        
        RndDataToArr vA, 16, 10, "mixed"
        vB = vA
    
    '-------------------------------------------
    'array to the worksheet
    '-------------------------------------------
        
        'clear the worksheet
        oSht.Cells.Clear
        
        'transfer array
        Arr1Dor2DtoWorksheet vA, "Sheet1", 1, 1
        
        'format columns of the sheet
        With oSht.Cells
            .Columns.AutoFit
            .NumberFormat = "General"
            .NumberFormat = "0.000" 'two decimals
        End With
    
    '-------------------------------------------
    'array formatted and to the immediate window
    '-------------------------------------------
        
        'clear the immediate window
        ClearImmWindow
        
        'formatted array to immediate window
        DispArrInImmWindow vB, True, 3, sIn
    
        'get formatted array string for further use
        sArr = sIn
    
    '--------------------------------------------
    'array formatted and to the clipboard
    '--------------------------------------------
        
        'formatted array string to clipboard
        CopyToClip sArr
    
    '--------------------------------------------
    'array formatted and to a text file or log
    '--------------------------------------------
        
        'retrieve clipboard string
        sOut = GetFromClip
    
        'formatted array string replaces text file content
        WriteToFile sOut, ThisWorkbook.Path & "\MyLongArray.txt"
    
    '---------------------------------------------
    'release object variables
    '---------------------------------------------
        
        Set oSht = Nothing
    
End Sub

Private Sub RndDataToArr(vIn As Variant, nRows As Integer, nCols As Integer, sType As String)
    'Loads a 2D array in place with a choice of random alpha strings
    'numbers or dates.
    
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    Dim nMinLenStr As Integer, nMaxLenStr As Integer
    Dim nMinLenDec As Integer, nMaxLenDec As Integer
    Dim nMinLenInt As Integer, nMaxLenInt As Integer
    Dim LA As Integer, LI As Integer, sT As String, sT2 As String
    Dim sAccum As String, sAccum1 As String, sAccum2 As String
    Dim nDec As Single, LD As Integer, nS As Integer, sDF As String
    Dim sAlpha As String, sInteger As String, sDecimal As String
    Dim r As Long, c As Long, bIncMinus As String, bNeg As Boolean
    Dim dMinDate As Date, dMaxDate As Date, nD As Long
    
    '------------------------------------------------------------------------
    'Parameter Notes:
    'sType sets the type of data to load into the array.
    '   "Alpha" loads random length strings of capitals - length set below
    '   "Integer" loads random length integers - length set below
    '   "Decimal" loads random integer and decimal parts - length set below
    '   "Dates"   loads random dates throughout - range set below
    '   "Mixed" loads alternate columns of alpha and decimal data - set below
    'nRows is the number of required array rows
    'nCols is the number of required array columns
    'vIn contains the input array
    '------------------------------------------------------------------------
    ReDim vIn(1 To nRows, 1 To nCols)
    
    LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
    LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
        
    '--------------------------------------------------
    'set user minimum and maximum settings here
    nMinLenStr = 3   'the minimum random text length
    nMaxLenStr = 8   'the maximum random text length
    nMinLenDec = 1   'the minumum decimal part length
    nMaxLenDec = 3   'the maximum decimal part length
    nMinLenInt = 1   'the minimum integer part length
    nMaxLenInt = 5   'the maximum integer part length
    dMinDate = #1/1/1900#     'earliest date to list
    dMaxDate = Date              'latest date to list
    sDF = "dddd, mmm d yyyy"      'random date format
    bIncMinus = True      'include random minus signs
    '--------------------------------------------------
    
    'randomize using system timer
    Randomize
          
    For r = LB1 To UB1
        For c = LB2 To UB2
            
            'get random lengths of elements
            Select Case LCase(sType)
            Case "alpha"
                LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
            Case "integer"
                LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
            Case "decimal"
                LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            Case "mixed"
                LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
                LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
                LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
            Case "dates"
            End Select
                    
            'make an alpha string
            Do
                sT = Chr$(Int((90 - 65 + 1) * Rnd + 65))
                sAccum = sAccum & sT
            Loop Until Len(sAccum) >= LA
            sAlpha = sAccum
            sAccum = "": sT = ""
                            
            'make an integer
            Do
                If LI = 1 Then 'zero permitted
                    sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
                    sAccum = sAccum & sT
                ElseIf LI > 1 And Len(sAccum) = 0 Then 'zero not permitted
                    sT = Chr$(Int((57 - 49 + 1) * Rnd + 49))
                    sAccum = sAccum & sT
                Else
                    sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
                    sAccum = sAccum & sT
                End If
            Loop Until Len(sAccum) >= LI
            sInteger = sAccum
            sAccum = "": sT = ""
                                       
            'make a decimal part
            Do
                sT2 = Chr$(Int((57 - 48 + 1) * Rnd + 48))
                sAccum2 = sAccum2 & sT2
            Loop Until Len(sAccum2) >= LD
            sDecimal = sAccum2
            sAccum = "": sAccum2 = "": sT2 = ""
                       
            'decide proportion of negative numbers
            nS = Int((3 - 0 + 1) * Rnd + 0)
            If nS = 1 And bIncMinus = True Then
                sInteger = "-" & sInteger
            End If
                            
            'assign value to array element
            Select Case LCase(sType)
            Case "alpha"
                vIn(r, c) = sAlpha
            Case "integer"
                vIn(r, c) = CLng(sInteger)
            Case "decimal"
                vIn(r, c) = CSng(sInteger & "." & sDecimal)
            Case "dates"
                nD = WorksheetFunction.RandBetween(dMinDate, dMaxDate)
                vIn(r, c) = Format(nD, sDF)
            Case "mixed"
                If c Mod 2 = 0 Then 'alternate columns alpha and decimal
                    vIn(r, c) = CSng(sInteger & "." & sDecimal)
                Else
                    vIn(r, c) = sAlpha
                End If
            End Select
        Next c
    Next r
End Sub

Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
                         ByVal nRow As Long, ByVal nCol As Long) As Boolean
    
    'Transfers a one or two dimensioned input array vA to the worksheet,
    'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
    'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
            
    Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
    Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
    Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
    
    'CHECK THE INPUT ARRAY
    On Error Resume Next
        'is it an array
        If IsArray(vA) = False Then
            bProb = True
        End If
        'check if allocated
        nR = UBound(vA, 1)
        If Err.Number <> 0 Then
            bProb = True
        End If
    Err.Clear
        
    If bProb = False Then
        'count dimensions
        On Error Resume Next
        Do
            nD = nD + 1
            nR = UBound(vA, nD)
        Loop Until Err.Number <> 0
    Else
        MsgBox "Parameter is not an array" & _
        vbCrLf & "or is unallocated - closing."
        Exit Function
    End If
    'get number of dimensions
    Err.Clear
    nDim = nD - 1: 'MsgBox nDim

    'get ref to worksheet
    Set oSht = ThisWorkbook.Worksheets(sSht)
       
    'set a worksheet range for array
    Select Case nDim
    Case 1 'one dimensional array
        LBR = LBound(vA): UBR = UBound(vA)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
    Case 2 'two dimensional array
        LBR = LBound(vA, 1): UBR = UBound(vA, 1)
        LBC = LBound(vA, 2): UBC = UBound(vA, 2)
        Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
    Case Else 'unable to print more dimensions
        MsgBox "Too many dimensions - closing"
        Exit Function
    End Select

    'transfer array values to worksheet
        rng.Value = vA
    
    'release object variables
    Set oSht = Nothing
    Set rng = Nothing
    
    'returns
    Arr1Dor2DtoWorksheet = True

End Function

Private Sub ClearImmWindow()
    
    'NOTES
    'Clears VBA immediate window down to the insertion point,
    'but not beyond. Not a problem as long as cursor is
    'at end of text, but otherwise not.
    'Clear manually before any neat work.
    'Manual clear method: Ctrl-G then Ctrl-A then Delete.
    
    'Max display in immediate window is 199 lines,
    'then top lines are lost as new ones added at bottom.
    'No reliable code method exists.
    
    Debug.Print String(200, vbCrLf)
    
End Sub

Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
                                  Optional ByVal nNumDecs As Integer = 2, _
                                     Optional sOut As String)

    '--------------------------------------------------------------------------
    'vA :               Input 2D array for display in the immediate window.
    'sOut:              Alternative formatted output string.
    'bFormatAlignData : True: applies decimal rounding and decimal alignment,
    '                   False: data untouched with only basic column spacing.
    'nNumDecs:          Sets the rounding up and down of decimal places.
    '                   Integers do not have zeros added at any time.
    'Clear the immediate window before each run for best results.
    'The immediate window at best lists 199 lines before overwrite, so
    'consider using sOut for large arrays.  'ie; use it in a text file
    'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
    'so set the font VBA editor or any textbox to Courier or Consolas.
    'To set different formats for EVERY column of an array it is best to add
    'the formats at loading time with the procedure TabularAlignTxtOrNumber().
    '--------------------------------------------------------------------------
    
    'messy when integers are set in array and decimals is set say to 3.
    'maybe the measurement of max element width should include a measure
    ' for any dot or extra imposed decimal places as well
    'different for integers and for existing decimals
        
    Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
    Dim sPadding As String, sDecFormat As String, sR As String, sE As String
    Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
    Dim nMaxFieldWidth As Integer, bSkip As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    
    'get bounds of input array
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
    
    ReDim vD(LB1 To UB1, LB2 To UB2) 'display
    ReDim vC(LB2 To UB2)             'column max
    
    '--------------------------------------
    'set distance between fixed width
    'fields in the output display
    nInterFieldSpace = 3
    'not now used
    nMaxFieldWidth = 14
    '--------------------------------------
    
    If nNumDecs < 0 Then
        MsgBox "nNumDecs parameter must not be negative - closing"
        Exit Sub
    End If
        
    'find widest element in each column
    'and adjust it for any imposed decimal places
    For c = LB2 To UB2
        n = 0: m = 0
        For r = LB1 To UB1
            'get element length
            If IsNumeric(vA(r, c)) Then
                If Int(vA(r, c)) = vA(r, c) Then 'is integer
                    n = Len(vA(r, c)) + 1 + nNumDecs
                Else 'is not integer
                    If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
                        n = Len(vA(r, c))
                    Else  'add the difference in length as result of imposed decimal places
                        n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
                    End If
                End If
            Else
                n = Len(vA(r, c))
            End If
            
            If n > m Then m = n 'update if longer
        Next r
        'store the maximum length
        'of data in each column
        vC(c) = m
    Next c
        
    For c = LB2 To UB2
        For r = LB1 To UB1
            sE = Trim(vA(r, c))

            If bFormatAlignData = False Then
                sDecFormat = sE
                nP = InStr(sE, ".")
                bSkip = True
            End If

            'make a basic format
            If bSkip = False Then
                nP = InStr(sE, ".")
                'numeric with a decimal point
                If IsNumeric(sE) = True And nP > 0 Then
                    sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
                'integer
                ElseIf IsNumeric(sE) = True And nP <= 0 Then
                    sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
                'alpha
                ElseIf IsNumeric(sE) = False Then
                    sDecFormat = sE
                End If
            End If
  
            'adjust field width to widest in column
            bSkip = False
            sPadding = Space$(vC(c))
            'numeric with a decimal point
            If IsNumeric(sE) = True And nP > 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'integer
            ElseIf IsNumeric(sE) = True And nP <= 0 Then
                vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
            'alpha
            ElseIf IsNumeric(sE) = False Then
                vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
            End If
        Next r
    Next c
        
    'output
    sOut = ""
    For r = LB1 To UB1
        For c = LB2 To UB2
            sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
        Next c
        Debug.Print sR             'print one row in imm window
        sOut = sOut & sR & vbCrLf  'accum one row in output string
        sR = ""
    Next r
    sOut = sOut & vbCrLf
    Debug.Print vbCrLf

End Sub

Private Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library.
    'Clipboard cleared when launch application closes.
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

Private Function GetFromClip() As String
    'passes clipboard text to function name
    'If clipboard not text, an error results
    'set reference to Microsoft Forms 2.0 Object Library.
    'Clipboard cleared when launch application closes.
    
    Dim DataIn As DataObject
    
    Set DataIn = New DataObject
    
    'clipboard text to dataobject
    DataIn.GetFromClipboard
    
    'dataobject text to function string
    GetFromClip = DataIn.GetText
    
    'release object variable
    Set DataIn = Nothing
    
End Function

Private Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

See Also[edit]



Charts from Arrays

Summary[edit]

Charts can be either embedded, where they are found in association with worksheets, or can occupy sheets of their own. The code example below makes basic charts on their own sheets. Purely to test the code, there is a procedure to fetch a selection of cells from the worksheet. Clearly, this procedure is justified only for testing since there are easier ways to make charts starting from a selection of cells. Array charting is generally most useful when data is not first written to a worksheet.

The chart procedure runs from an array. The array can contain one X series, and any practical number of Y series. However, the layout of the array is strict; the first row must contain only X data. All other rows will be treated as having Y series data in them. No heading labels can be included.

If the source data has its series in columns instead of the rows required by the chart array, then the data is transposed before the charting point. A transpose procedure is included in the code.

The code can be tested as a self-contained standard module.

The VBA Code[edit]

Because there are too many variations of chart types to accommodate with any accuracy, only the most general properties can be considered in one procedure. As a result, the user should add any specific code to the appropriate sections.

Note that in the supporting procedures, both empty selections and insufficient selections generate errors, so a minimal error handling was added.

Option Explicit

Sub ChartFromSelection()
    'select a block of cells to chart - then run;
    'either; top row X data, and all other rows Y series, or
    'first column X data, and all columns Y series;
    'set boolean variable bSeriesInColumns to identify which:
    'Do not include heading labels in the selection.
    
    Dim vA As Variant, bOK1 As Boolean, bOK2 As Boolean
    Dim bTranspose As Boolean, bSeriesInColumns As Boolean
    
    'avoid errors for 'no selection'
    On Error GoTo ERR_HANDLER
        
    'set for series in rows (True), or in columns (False)
    bSeriesInColumns = False
    
    'load selection into array
    LoadArrSelectedRange vA, bSeriesInColumns
    
    'make specified chart type
    ChartFromArray vA, xlLine
    
    'advise complete
    MsgBox "Chart done!"
    ActiveChart.ChartArea.Activate
    Exit Sub

ERR_HANDLER:
    Select Case Err.Number
        Case 13 'no selection made
            Err.Clear
            MsgBox "Make a 2D selection of cells"
            Exit Sub
        Case Else
            Resume Next
    End Select

End Sub

Public Function LoadArrSelectedRange(vR As Variant, Optional bTranspose As Boolean = False) As Boolean
    'gets the current selection of cells - at least 2 cols and 2 rows, ie, 2 x 2
    'and returns data array in vR
    'if bTranspose=True then selection is transposed before loading array
    'before array storage - otherwise as found
    
    Dim vA As Variant, rng As Range
    Dim sht As Worksheet, vT As Variant
    Dim r As Long, c As Long
    Dim lb1, ub1, lb2, ub2
    Dim nSR As Long, nSC As Long
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'make sure a range is selected
    If TypeName(Selection) <> "Range" Then Exit Function
    
    'find bounds of selection
    With Application.Selection
        nSR = .Rows.Count
        nSC = .Columns.Count
    End With
    
    'check that enough data is selected
    If nSC < 2 Or nSR < 2 Then
        MsgBox "No useful selection was found." & vbCrLf & _
               "Needs at least two rows and two columns" & vbCrLf & _
               "for array 2D loading."
        Exit Function
    End If
    
    'dimension work array
    ReDim vA(1 To nSR, 1 To nSC)
        
    'get range of current selection
    Set rng = Application.Selection
        
    'pass range of cells to array
    vA = rng
    
    'output transposed or as found
    If bTranspose = True Then
        TransposeArr2D vA, vT
        vR = vT
    Else
        vR = vA
    End If
        
    'collapse selection to top left
    sht.Cells(1, 1).Select
    
    'transfers
    LoadArrSelectedRange = True

End Function

Function ChartFromArray(ByVal vA As Variant, Optional vChartType As Variant = xlLine) As Boolean
    'assumes multi series are in array ROWS
    'if data in columns then transpose it before call
    'at this point vA must have X values in first row
    'and all other rows assumed to be Y series
    'only data - no label columns
    
    'Chart type notes
    '================================
    'xlArea,
    'xlBarClustered
    'xlLine, xlLineMarkers
    'xlXYScatter, xlXYScatterLines
    'xlPie, xlPieExploded
    'xlRadar, xlRadarMarkers
    'xlSurface, xlSurfaceTopView
    'see link in ChartType help page
    'for full list of chart types
    '================================
    
    Dim lb1 As Long, ub1 As Long, lb2 As Long, ub2 As Long
    Dim X As Variant, Y As Variant, oChrt As Chart
    Dim n As Long, m As Long, S As Series, bTrimAxes As Boolean
    Dim sT As String, sX As String, sY As String
    
    'set axes labels
    sT = "Top Label for Chart Here"
    sX = "X-Axis Label Here"
    sY = "Y-Axis Label Here"
    
    'set boolean to True to enable axes trimming code block
    bTrimAxes = False
    
    'get bounds of array
    lb1 = LBound(vA, 1): ub1 = UBound(vA, 1)
    lb2 = LBound(vA, 2): ub2 = UBound(vA, 2)
    
    
    ReDim X(lb2 To ub2) '1 to 11 data
    ReDim Y(lb2 To ub2) '1 to 11 data

    'make a chart
    Set oChrt = Charts.Add
        
    'use parameter chart type
    oChrt.ChartType = vChartType
    
    'load the single X series
    For n = lb2 To ub2
        X(n) = vA(lb1, n)
    Next n
        
    'remove unwanted series
    With oChrt
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With
    
    'add the intended series
    For m = 2 To ub1
        'load one Y series at a time
        For n = lb2 To ub2
            Y(n) = vA(m, n)
        Next n
                
        'make new series object
        Set S = ActiveChart.SeriesCollection.NewSeries
        
        'transfer series individually
        With S
            .XValues = X
            .Values = Y
            .Name = "Series names"
        End With
    Next m
        
    'APPLY ALL OTHER CHART PROPERTIES HERE
    On Error Resume Next 'avoid display exceptions
        With oChrt
          'CHART-SPECIFIC PROPERTIES GO HERE
            Select Case .ChartType
                Case xlXYScatter
                Case xlLine
                Case xlPie
                Case xlRadar
                Case xlSurface
            End Select
            
          'GENERAL CHART PROPERTIES GO HERE
            'labels for the axes
            .HasTitle = True
            .ChartTitle.Text = sT 'chart title
            .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
            .Axes(xlCategory).AxisTitle.Text = sX 'X
            .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
            .Axes(xlValue).AxisTitle.Text = sY    'Y
            .Legend.Delete
        
            If bTrimAxes = True Then
                'X Axis limits and such- set as required
                .Axes(xlCategory).Select
                .Axes(xlCategory).MinimumScale = 0
                .Axes(xlCategory).MaximumScale = 1000
                .Axes(xlCategory).MajorUnit = 500
                .Axes(xlCategory).MinorUnit = 100
                Selection.TickLabelPosition = xlLow
        
                'Y Axis limits and such- set as required
                .Axes(xlValue).Select
                .Axes(xlValue).MinimumScale = -0.2
                .Axes(xlValue).MaximumScale = 1.2
                .Axes(xlValue).MajorUnit = 0.1
                .Axes(xlValue).MinorUnit = 0.05
             End If
        End With
    On Error GoTo 0
    oChrt.ChartArea.Select
    Set oChrt = Nothing
    Set S = Nothing
    
    ChartFromArray = True
    
End Function

Function TransposeArr2D(vA As Variant, Optional vR As Variant) As Boolean
        
    '---------------------------------------------------------------------------------
    ' Procedure : Transpose2DArr
    ' Purpose   : Transposes a 2D array; rows become columns, columns become rows
    '             Specifically, (r,c) is moved to (c,r) in every case.
    '             Options include, returned in-place with the source changed, or
    '             if vR is supplied, returned in that instead, with the source intact.
    '---------------------------------------------------------------------------------
    
    Dim vW As Variant
    Dim loR As Long, hiR As Long, loC As Long, hiC As Long
    Dim r As Long, c As Long, bWasMissing As Boolean
    
    'find whether optional vR was initially missing
    bWasMissing = IsMissing(vR)
    If Not bWasMissing Then Set vR = Nothing
    
    'use a work array
    vW = vA
    
    'find bounds of vW data input work array
    loR = LBound(vW, 1): hiR = UBound(vW, 1)
    loC = LBound(vW, 2): hiC = UBound(vW, 2)
    
    'set vR dimensions transposed
    'Erase vR 'there must be an array in the variant to erase
    ReDim vR(loC To hiC, loR To hiR)
    
    'transfer data
    For r = loR To hiR
        For c = loC To hiC
            'transpose vW into vR
            vR(c, r) = vW(r, c)
        Next c
    Next r
    
    'find bounds of vW data input work array
'    loR = LBound(vR, 1): hiR = UBound(vR, 2)
'    loC = LBound(vR, 2): hiC = UBound(vR, 2)


TRANSFERS:
    'decide whether to return in vA or vR
    If Not bWasMissing Then
        'vR was the intended return array
        'so leave vR as it is
    Else:
        'vR is not intended return array
        'so reload vA with vR
        vA = vR
    End If
    
    'return success for function
    TransposeArr2D = True
    
End Function

Sub LoadArrayTestData()
    'loads an array with sample number data
    'first row values of x 1 to 100
    'next three rows y series
    
    Dim nNS As Long, f1 As Single
    Dim f2 As Single, f3 As Single
    Dim vS As Variant, vR As Variant, n As Long
    
    'dimension work array
    nNS = 50
    ReDim vS(1 To 4, 1 To nNS)
    
    'make function loop
    For n = 1 To nNS
        f1 = (n ^ 1.37 - 5 * n + 1.5) / -40
        On Error Resume Next
        f2 = Sin(n / 3) / (n / 3)
        f3 = 0.015 * n + 0.25
        vS(1, n) = n  'X
        vS(2, n) = f1 'Y1
        vS(3, n) = f2 'Y2
        vS(4, n) = f3 'Y3
    Next n
    
    ChartFromArray vS, xlLine

End Sub

Sub DeleteAllCharts6()
    'run this to delete all ThisWorkbook charts
    
    Dim oC
       
    Application.DisplayAlerts = False
    
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    
    Application.DisplayAlerts = True
    
End Sub



Character Frequency Charts in Excel

Summary[edit]

VBA Code Listings[edit]

At times it is useful to make an Excel chart from VBA. The code below makes a frequency bar chart based on a given string. It is shown in testing mode with a random string input. The user should replace that string with his own. There are various charting options.

Option Explicit

Sub Test()
    'run this to test the charting of this module
    
    Dim str As String, n As Long
    
    'make random mixed characters (for testing only)
    str = MakeLongMixedString(10000)
    
    'make a sorted frequency chart of the characters in str
    MakeCharaFreqChart str, 1, "n"
    
    MsgBox "Chart done"
    
End Sub

Function MakeLongMixedString(nNumChr As Long) As String
    'Makes a long capital letters string using rnd VBA function
    
    Dim n As Long, sChr As String, nAsc As Long
    Dim nSamp As Long, sAccum As String, c As Long
    
    '========================================================================
    ' Notes and Conclusions:
    ' The VBA function rnd is UNSUITED to generation of long random strings.
    ' Both length and number of repeats increases rapidly near 256 charas.
    ' Reasonable results can be obtained by keeping below 128 characters.
    ' For longer strings, consider hash-based methods of generation.
    '========================================================================
        
    Do Until c >= nNumChr
        DoEvents
        Randomize
        'A to Z corresponds to asci 65 to 90
        nSamp = Int((90 - 48 + 1) * Rnd + 48)
        If (nSamp >= 48 And nSamp <= 57) Or (nSamp >= 65 And nSamp <= 90) Then
           sChr = Chr(nSamp)
           sAccum = sAccum & sChr
           c = c + 1
        End If
    Loop
    
    'MsgBox sAccum
    
    MakeLongMixedString = sAccum

End Function

Sub MakeCharaFreqChart(str As String, bSort As Boolean, sYUnits As String)
    'For use in Excel
    'makes a character frequency chart using the parameter string str
    'bSort=True to sort the chart from highest (left) otherwise unsorted
    'sYUnits string sets measurement method, number charas, percentage total, or normalised to max value
    
    Dim vC As Variant, nRow As Long, vRet As Variant
    
    GetCharaCounts str, vC
    
    Select Case LCase(sYUnits)
    Case "n", "numbers", "number", "count", "#"
        nRow = 1
    Case "p", "percent", "percentage", "%"
        nRow = 2
    Case "r", "relative", "normalized", "normalised"
        nRow = 3
    End Select
    
    If bSort Then
        SortColumns vC, 1, 0, vRet
        ChartColumns vRet, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
        "Character Set of Interest", "Number of Each"
    Else
        ChartColumns vC, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
        "Character Set of Interest", "Number of Each"
    End If
    
End Sub

Sub GetCharaCounts(sIn As String, vR As Variant)
    'loads an array with character counts
    
    Dim vRef As Variant, LBC As Long, UBC As Long, LBR As Long, UBR As Long
    Dim vW() As Variant, X() As Variant, Y() As Variant, vRet As Variant
    Dim sUC As String, nC As Long, n As Long, sS As String, ValMax As Variant
    
    'Notes for vR and vW loads
    'Row 0: the ref chara set from vRef
    'Row 1: the number of hits found in str for each chara in ref set
    'Row 2: the percentage that hits rep of total charas in str
    'Row 3: the normalized values for each chara with max as unity
    
    If sIn = "" Then
        MsgBox "Empty input string - closing"
        Exit Sub
    End If
    
    'load the intended x-axis display set here...add to it or subtract as required
    vRef = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
    "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
    "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")       ' ,"(", ")", ":", ".", ",")
    
    LBC = LBound(vRef): UBC = UBound(vRef)
    ReDim vW(0 To 3, LBC To UBC)
    LBR = LBound(vW, 1): UBR = UBound(vW, 1)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)
    
    sUC = UCase(sIn)
    nC = Len(sIn)
    For n = LBC To UBC
        vW(0, n) = vRef(n) 'all charas to first row
        sS = vW(0, n)
        'count hits in string for each chara in ref set
        vW(1, n) = UBound(Split(sUC, sS)) - LBound(Split(sUC, sS)) 'count hits
        'calculate hits as percentages of total chara count
        vW(2, n) = Round(((vW(1, n)) * 100 / nC), 1)
    Next n
    
    'find max value in array count
    SortColumns vW, 1, False, vRet
    ValMax = vRet(1, 0)
    
    'normalize to unity as max value
    For n = LBC To UBC
        vW(3, n) = Round(vW(1, n) / ValMax, 1)
    Next n
    
    vR = vW()
    
End Sub

Sub ChartColumns(ByVal VA As Variant, bColChart As Boolean, RowX As Long, RowY As Long, _
    Optional bXValueLabels As Boolean = 0, Optional sTitle As String = "", _
    Optional sXAxis As String, Optional sYAxis As String)
    'this is the actual chart procedure. It charts the array data in VA 
    'the array must contain two data rows for the chart; with x and y data
    'the chart can be column or scatter chart; RowX and RowY parameters identify the data rows for each axis.
    'optional parameters are included for value labels, chart title, x axis label, and y axis label
    
    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long
    Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
    
    LBR = LBound(VA, 1): UBR = UBound(VA, 1)
    LBC = LBound(VA, 2): UBC = UBound(VA, 2)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)
    
    'labels for specific charts
    If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
    If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
    If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
    
    If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
        MsgBox "Parameter data rows out of range in ChartColumns - closing"
        Exit Sub
    End If
    
    'transfer data to chart arrays
    For n = LBC To UBC
        X(n) = VA(RowX, n) 'x axis data
        Y(n) = VA(RowY, n) 'y axis data
    Next n
    
    'make chart
    Charts.Add
    
    'choose a column chart or a scatter chart
    If bColChart Then
        ActiveChart.ChartType = xlColumnClustered 'column chart
    Else
        ActiveChart.ChartType = xlXYScatterLinesNoMarkers 'line scatter chart
        'ActiveChart.ChartType = xlXYScatter 'point scatter chart
End If
    
    'assign the data and labels to a series
    With ActiveChart.SeriesCollection
        If .Count = 0 Then .NewSeries
            If bXValueLabels And bColChart Then
                .Item(1).ApplyDataLabels Type:=xlDataLabelsShowValue
                'item(1).DataLabels.Orientation = xlUpward
                .Item(1).DataLabels.Orientation = 60
            End If
            If Val(Application.Version) >= 12 Then
                .Item(1).Values = Y
                .Item(1).XValues = X
            Else
                .Item(1).Select
                Names.Add "_", X
                ExecuteExcel4Macro "series.x(!_)"
                Names.Add "_", Y
                ExecuteExcel4Macro "series.y(,!_)"
                Names("_").Delete
            End If
        End With
        
        'apply title string, x and y axis strings, and delete legend
        With ActiveChart
            .HasTitle = True
            .ChartTitle.Text = sT
            .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
            .Axes(xlCategory).AxisTitle.Text = sX
            .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
            .Axes(xlValue).AxisTitle.Text = sY
            .Legend.Delete
        End With
        
        ActiveChart.ChartArea.Select
    
End Sub

Sub SortColumns(ByVal VA As Variant, nRow As Long, bAscend As Boolean, vRet As Variant)
    'bubblesorts the input array's columns using values in the specified row, ascending or descending, ret in vRet
    
    Dim i As Long, j As Long, bCond As Boolean, Y As Long, t As Variant
    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long
    
    LBR = LBound(VA, 1): UBR = UBound(VA, 1)
    LBC = LBound(VA, 2): UBC = UBound(VA, 2)
    
    For i = LBC To UBC - 1
        For j = LBC To UBC - 1
            If bAscend Then
                bCond = VA(nRow, j) > VA(nRow, j + 1)
            Else
                bCond = VA(nRow, j) < VA(nRow, j + 1)
            End If
            If bCond Then
                For Y = LBR To UBR
                    t = VA(Y, j)
                    VA(Y, j) = VA(Y, j + 1)
                    VA(Y, j + 1) = t
                Next Y
            End If
        Next j
    Next i
    
    vRet = VA
    
End Sub

Sub DeleteAllWorkbookCharts()
    'run this manually to delete all charts
    'not at this stage called in any procedure
        
    Dim oC
    
    Application.DisplayAlerts = False
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    Application.DisplayAlerts = True
    
End Sub



Clipboard VBA

Summary[edit]

There are three main ways to pass text to and from the clipboard with VBA code.

  • The DataObject method:
    • This is perhaps the simplest implementation.
    • Its main restriction is that the contents of the clipboard will be lost when the launching application is closed; generally this is not a problem when running Excel modules, but should be borne in mind.
    • Some users elsewhere report bugs. See DataObject Bugs Forum for details of the bugs and one suggested fix. All of the procedures on this page are tested and work well in both Windows 7 and Windows 8.1 for Excel 2010. The DataObject method has recently been adopted for the VBA Indenter module, in this same series.
    • Other methods avoid these restrictions. In the unlikely event of problems with these procedures, either of the next two methods would suffice.
    • An example of the DataObject method is given in section two of this page.
  • User form control methods:
    • When user forms are to be displayed, then the copy and paste methods of the text box can be used. These methods work well and are well tested.
    • When no user form is to be displayed, a hidden form can be used. The form with a text box, is loaded but never displayed. Then, the invisible user form's controls can still then be coded as normal. The text box must have its Multiline property set to true for most useful text transfers. It will be found best, in general,to set the form's ShowModal property to False; this allows for convenient code tracing and avoids many other confusions.
    • An example of the hidden user form method is given in section four. Another example in section three, for a visible user form, shows how to track the active text box prior to copy.
  • API methods:
    • These methods make use of Windows libraries, and have copious declarations in their module headings. That said, they work well, and are described by Microsoft documentation as being the most suitable.
    • One example of API use is displayed in section five. See Send-Information-to-the-Clipboard for more details.

DataObject Method[edit]

  • These methods make used of a DataObject . They are by far the most adaptable, since any text that can be placed in a variable can then be placed onto the clipboard using the PutInClipboard method. Text can also be brought into a VBA string variable with the GetFromClipboard method. The procedures CopyToClip() and GetFromClip() in the example below first send text to the clipboard, then fetch it again, before displaying the text in a message box. Set a reference to Microsoft Forms 2 in the editor options for this; if you cannot find it just add a user form to your project and it will be added to the selections.
  • Reports of bugs in DataObject methods are reported elsewhere. These apply to Windows versions beyond Win 7, and are reported to involve an unusual persistence between the object and the clipboard. If difficulty is found with these methods then either the dummy userform method or the API methods could be tried.
Sub testCopyAndPaste()
    'demonstrates copy and paste of text to variables
    'loads clipboard with date-time text then
    'fetches it back for display
    'Only good for text and clipboard content lost
    'when application closes.
        
    Dim sStrOut As String, sStrIn As String
    
    'get the current date-time string
    sStrOut = Now
    
    'copy text to clipboard
    CopyToClip sStrOut

    'retrieve from clipboard
    sStrIn = GetFromClip
    
    'display recovered text
    MsgBox sStrIn

End Sub

Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library.
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

Function GetFromClip() As String
    'passes clipboard text to function name
    'If clipboard not text, an error results
    'set reference to Microsoft Forms 2.0 Object Library.
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    
    Dim DataIn As DataObject
    
    Set DataIn = New DataObject
    
    'clipboard text to dataobject
    DataIn.GetFromClipboard
    
    'dataobject text to function string
    GetFromClip = DataIn.GetText
    
    'release object variable
    Set DataIn = Nothing
    
End Function

Visible User Form Method[edit]

The code module below provides the VBA code for a form module, (shown here as UserForm1). In it there are command button click routines for textbox Copy and Paste. To use the copy procedure the user simply selects some text then presses the button on the user form. To paste the contents of the clipboard into a textbox, the user must first place the insertion point somewhere within a textbox before pressing the requisite button.

In order to clarify which textbox is active, there is a mouse-up event for each, where a number is loaded into a module-level variable whenever a mouse is used in the box. Although this code is made for three textboxes, it can easily be extended to any number.

The code assumes that there is a user form UserForm1, with TextBox1, TextBox2, TextBox3, CommandButton1 and CommandButton2 in it. In addition, note that there is a module level variable in the code. Since the VBA code is fairly generic it applies to most MS Office applications.

Option Explicit
Dim nActTxtBx As Integer

Private Sub CommandButton1_Click()
'this is the "Paste at Cursor" button
'pastes clipboard active textbox's insertion point
'ie; the textbox last clicked with mouse
            
    Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
    Dim oFrm As UserForm, oTxt As Control, s As Long
    
    Set oFrm = UserForm1
    Set oTxt1 = oFrm.TextBox1
    Set oTxt2 = oFrm.TextBox2
    Set oTxt3 = oFrm.TextBox3
    
    'get the textbox with the focus
    Select Case nActTxtBx
    Case 0
        MsgBox "Please place the insertion point."
        Exit Sub
    Case 1
        Set oTxt = oTxt1
    Case 2
        Set oTxt = oTxt2
    Case 3
        Set oTxt = oTxt3
    Case Else
        Exit Sub
    End Select
    
    s = oTxt.SelStart
    With oTxt
        .Paste
        .SetFocus
        .SelStart = s
    End With

    Set oFrm = Nothing: Set oTxt = Nothing
    Set oTxt1 = Nothing: Set oTxt2 = Nothing
    Set oTxt3 = Nothing
End Sub

Private Sub CommandButton2_Click()
'this is the "Copy Selected Text" button
'copies selected text from textbox to clipboard
'ie; the textbox last clicked with mouse

    Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
    Dim oFrm As UserForm, oTxt As Control
    
    Set oFrm = UserForm1
    Set oTxt1 = oFrm.TextBox1
    Set oTxt2 = oFrm.TextBox2
    Set oTxt3 = oFrm.TextBox3
    
    'get reference to active textbox
    Select Case nActTxtBx
    Case 0
        MsgBox "Please make a selection."
        Exit Sub
    Case 1
        Set oTxt = oTxt1
    Case 2
        Set oTxt = oTxt2
    Case 3
        Set oTxt = oTxt3
    Case Else
        Exit Sub
    End Select
    
    'check that a selection was made
    'MsgBox oTxt.SelLength
    If oTxt.SelLength = 0 Then
        MsgBox "No selection found."
        Exit Sub
    End If
    
    With oTxt
        .Copy
        .SetFocus
        .SelStart = 0
    End With

    Set oFrm = Nothing: Set oTxt = Nothing
    Set oTxt1 = Nothing: Set oTxt2 = Nothing
    Set oTxt3 = Nothing

End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 1
End Sub

Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 2
End Sub

Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 3
End Sub

Hidden User Form Method[edit]

This code should be placed in a standard module. The project needs a user form called Temp, with a single TextBox1 set with MultiLine=true. TextBox contents are always text.

Option Explicit

Sub TestClipboardProcs()
'run this
    
    CopyToClipboard "The string" & vbCrLf & _
                    "to copy..."
    MsgBox GetClipboard2

End Sub

Function GetClipboard2() As String
'PASTES clipboard into function name as a text string
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
    
    Dim oTxt1 As Control, oFrm As UserForm
    Dim s As Long
    
    'load the temporary form
    Load Temp
    
    Set oFrm = Temp
    Set oTxt1 = oFrm.TextBox1
        
    s = oTxt1.SelStart
    With oTxt1
        .Paste
        .SetFocus
        .SelStart = s
    End With
    
    GetClipboard2 = oTxt1.Value
        
    Set oTxt1 = Nothing
    Set oFrm = Nothing
    Unload Temp

End Function

Function CopyToClipboard(sStr As String) As Boolean
'COPIES parameter variable text string value to clipboard
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
    
    Dim oTxt1 As Control, oFrm As UserForm
    
    If sStr = "" Then
        MsgBox "Clipboard cannot hold an empty string."
        Exit Function
    End If
        
    'load the temporary form
    Load Temp
    
    Set oFrm = Temp
    Set oTxt1 = oFrm.TextBox1
    
    oTxt1.Value = sStr
        
    'copy textbox value to clipboard
    With oTxt1
        .SelStart = 0 'set up the selection
        .SelLength = .TextLength
        .Copy
        .SetFocus
        .SelStart = 0
    End With
        
    Set oTxt1 = Nothing
    Set oFrm = Nothing
    Unload Temp

    CopyToClipboard = True

End Function

API Method[edit]

The following VBA code makes use of API calls, and is recommended by Microsoft in their MS Access page Send-Information-to-the-Clipboard. Such methods should overcome the current bugs in the the DataObject methods for Windows 8 and 10. The code should be copied into a standard module in its entirety.

Option Explicit
'Declarations for functions SetClipboard() and GetClipboard()
''from https://docs.microsoft.com/en-us/office/vba/access/concepts/windows-api/send-information-to-the-clipboard
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

Sub TestCopyPasteAPI()
    'API methods for clipboard
    Dim sIn As String, sOut As String
    
    sIn = "Sausages"
    SetClipboard sIn
    sOut = GetClipboard
    MsgBox sOut

End Sub

Public Sub SetClipboard(sUniText As String)
    'sets the clipboard with parameter string
      
    Dim iStrPtr As Long, iLen As Long
    Dim iLock As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard

End Sub

Public Function GetClipboard() As String
    'gets the clipboard text in function name
    
    Dim iStrPtr As Long, iLen As Long
    Dim iLock As Long, sUniText As String
    Const CF_UNICODETEXT As Long = 13&
    
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard

End Function

See Also[edit]

  • Send-Information-to-the-Clipboard: A clearly worded page by Microsoft showing how to use API methods for the clipboard. Although described for MS Access, it works in MS Excel just as well.
  • DataObject Bugs Forum: A description of a DataObject bug for Windows versions beyond Win7.



Simple Vigenere Cipher in VBA

Summary[edit]

  • This VBA code module runs the Vigenere cipher for user strings. It is used to conceal the contents of a message. The sender and recipient share a secret word or phrase, the so-called key, used to scramble (encrypt) and unscramble (decrypt) the message. The code is intended for Microsoft Excel, but is easily adapted to work in other MS Office products that run VBA. For simplicity, the code could have been restricted to capital letters, but it was decided to include integers for a more useful tool.
  • Figure 1 shows a Vigenere table without integers or other characters. Figure 2, the basis for the coding, shows a similar table that includes integers. These types of table have been in use since the sixteenth century.
  • The Vigenere cipher makes use of a repeated keyword or phrase. That is to say, the key string is repeated as often as necessary to cover the message, prior to working. This can be seen in the example of Figure 1, where the keyword "BULGE" was extended to "BULGEBUL" to cover the eight characters of the message.
  • The coded version of the cipher uses a calculation to simulate the tabular method. The twenty-six letters of the alphabet and the ten integers are assigned number values between zero and thirty-five. Then, for encryption, key values are modulo-36 added to message values to make the ciphertext. For decryption, key values are subtracted from the ciphertext, again using modulo-36 arithmetic, and always producing positive values. Numbers are converted back to characters for display.

Notes on the Code[edit]

Figure 1: The Vigenere cipher uses the intersection of table entries for encryption and a reverse lookup for decryption. Notice in this example that the two instances of the letter E were encrypted differently. The extended table that is the basis of the coding however, can be found in Figure 2.
  • No userform is provided. Instead, type message and key strings, and the boolean value for the working mode, into the top procedure directly. Interested parties might well add a user form of their own.
  • CheckInputs() makes sure that no illegal characters are included. The procedure LongKey() makes a key value equal in length to the message.
  • CharaToMod36() converts each string character, of both message and key, to its set position number. Another procedure, Mod36ToChara() converts these numbers back again prior to display.
  • AddMod36() performs modulo-36 addition, and subtracts 36 from numbers larger than 35 to keep the result within the set. The procedure SubMod36() performs subtraction, and adds 36 to any negative results, again, to keep the number within range.
  • More work could be done to improve the code. For example, the set could be extended. The key could be tested to avoid some of the flaws that are characteristic of this cipher. As mentioned before, a user form could be made to replace direct entry, perhaps with clipboard functions.
  • Because patterns can develop, some care is needed in its use. Clearly, a key that consists only of one repeated character would not be very secure, especially if it were the letter A. (Try it!). A good mixture of characters makes for the best key, and if the key completely covers the message without repetition, so much the better. This latter situation helps to avoid patterns that might make for easier cracking. In fact, if instead of a repeated key, a hash of the key were used, many of these pattern weaknesses might be avoided. Those who have an interest in such modifications will find (use base64 output) hash procedures elsewhere in this series. That said, care should be taken to include only alpha characters and integers from any such hash, or errors will result. (B64 strings from hash algorithms typically have three additional symbol characters to avoid, =, +, and /. )

A Larger Vigenere Table[edit]

Figure 2: Vigenere Cipher Table with Capitals and Integers
Vigenere Capitals and Integers 2.png


If all else fails, and for those who prefer manual working anyway, the table in the above drop-box may be found useful. It lists both capitals and integers. Notice that although both tables have a passing similarity, their content is quite different, so are not interchangeable.

A Worked Example[edit]

The following panel shows how the calculation works for the coded version. It is analogous to the adding and subtraction of character distances within a closed set. Other implementations of the manual method have included the sliding of one set of characters against another for the required distances, sometimes using concentric discs. Figure 2 can be interpreted as a listing of every possible combination of messages and keys.

        THE CHARACTER SET AND ITS VALUES
         A    B    C    D    E    F    G    H    I    J    K    L    M
         0    1    2    3    4    5    6    7    8    9   10   11   12 
         
         N    O    P    Q    R    S    T    U    V    W    X    Y    Z
        13   14   15   16   17   18   19   20   21   22   23   24   25 

         0    1    2    3    4    5    6    7    8    9
        26   27   28   29   30   31   32   33   34   35
        
        
        ENCRYPTION WORKING
         S    E    N    D    H    E    L    P      message               (1)
         B    U    L    G    E                     key             
         B    U    L    G    E    B    U    L      extended key          (2)
        18    4   13    3    7    4   11   15      message values        (3) 
         1   20   11    6    4    1   20   11      key values            (4)
        19   24   24    9   11    5   31   26      (3)+(4)               (5)
         T    Y    Y    J    L    F    5    0      cipher text (Note 1)  (7)

        Note 1:   Subtract 36 from any numbers here that might exceed 35.
        
        Notice that each instance of "E" results in different cipher text.
        
        DECRYPTION WORKING
         T    Y    Y    J    L    F    5    0      cipher text           (8)
         B    U    L    G    E                     key             
         B    U    L    G    E    B    U    L      extended key          (9)
        19   24   24    9   11    5   31   26      cipher text values   (10)         
         1   20   11    6    4    1   20   11      key values           (11)
        18    4   13    3    7    4   11   15      (10) minus (11)      (12)   
         S    E    N    D    H    E    L    P      plain text (Note 2)  (15) 

        Note 2:   Add 36 to any numbers here that might become negative.
        

The VBA Code Module[edit]

Copy this entire code listing into an Excel standard module, save the file as a xlsm type, then run the top procedure. No user form code has been provided, so the user should enter his message (sTxt) and key (sKey) strings directly into the section identified in the top procedure. Be sure to identify whether encryption or decryption is intended with the setting of the variable bEncrypt.

Option Explicit

Sub EncryptDecrypt()
    'Run this procedure for a simple Vigenere encryption/decryption
    'Capital letters and integers only; no symbols; no spaces.(ie: mod36 working).
    'Set message, key and mode directly in this procedure before running it.
    'Output to a message box and Excel. Overwrites some cells in Sheet1.
    
    Dim vA() As String, oSht As Worksheet
    Dim nM As Long, c As Long
    Dim sTxt As String, sK As String
    Dim sKey As String, sMode As String, sAccum As String
    Dim bEncrypt As Boolean, bMOK As Boolean, bKOK As Boolean
    
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    '-------------------------USER ADDS DATA HERE------------------------
    'user should enter texts and encrypt/decrypt choice here
    sTxt = "2019forthecup"  'text to process, plain or cipher
    sKey = "BOGEYMAN"       'Key word or phrase
    bEncrypt = True         'set True for encrypt; False for decrypt
    '---------------------------------------------------------------------
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'convert both strings to upper case
    sTxt = UCase(sTxt)
    sKey = UCase(sKey)
    
    'check the message and key for illegal characters
    'restricted here to capital letters and integers only
    bMOK = CheckInputs(sTxt)
    bKOK = CheckInputs(sKey)
    If bMOK = False Or bKOK = False Then
        If sTxt <> "" And sKey <> "" Then
            MsgBox "Illegal characters found."
        Else
            MsgBox "Empty strings found."
        End If
        Exit Sub
    End If
    
    'make an extended key to match the message length
    nM = Len(sTxt)
    sKey = LongKey(sKey, nM)
        
    'dimension a work array equal in length to the message
    ReDim vA(1 To 10, 1 To nM) '10 rows and nM columns
    
    'read the message, key, and mod-36 values into array
    For c = LBound(vA, 2) To UBound(vA, 2) 'r,c
        'text chara by chara
        vA(1, c) = CStr(Mid$(sTxt, c, 1)) 'message charas
        vA(2, c) = CStr(Mid$(sKey, c, 1)) 'key charas
        'text's converted number values
        vA(3, c) = CStr(CharaToMod36(Mid$(sTxt, c, 1))) 'number values of charas
        vA(4, c) = CStr(CharaToMod36(Mid$(sKey, c, 1))) 'number values of charas
    Next c
       
    'steer code for encrypt or decrypt
    If bEncrypt = True Then 'encrypt
        sMode = " : Encryption result" 'display string
        GoTo ENCRYPT
    Else
        sMode = " : Decryption result" 'display string
        GoTo DECRYPT
    End If

ENCRYPT:
    'sum of converted key and message values mod-26
    'then find string character values of sums
    For c = LBound(vA, 2) To UBound(vA, 2)
        vA(5, c) = CStr(AddMod36(CLng(vA(3, c)), CLng(vA(4, c))))
        vA(6, c) = Mod36ToChara(CLng(vA(5, c)))
    Next c
    
    'accumulate the encrypted charas into a single display string
    'for message box and worksheet
    For c = LBound(vA, 2) To UBound(vA, 2)
        sAccum = sAccum & vA(6, c) 'mixed
    Next c
    GoTo DISPLAY

DECRYPT:
    'subtract key values from encrypted chara values
    'and make negative values positive by adding 26
    'Find string character values of the differences
    For c = LBound(vA, 2) To UBound(vA, 2)
        vA(5, c) = CStr(SubMod36(CLng(vA(3, c)), CLng(vA(4, c))))
        vA(6, c) = Mod36ToChara(CLng(vA(5, c)))
    Next c
    
    'accumulate the encrypted charas into a display string
    'for message box and worksheet
    For c = LBound(vA, 2) To UBound(vA, 2)
        sAccum = sAccum & vA(6, c) 'mixed
    Next c
    GoTo DISPLAY

DISPLAY:
    'message box display
    MsgBox sTxt & " : Text to Process" & vbCrLf & _
           sKey & " : Extended Key" & vbCrLf & _
           sAccum & sMode
    'and output to sheet1 in monospaced font
    With oSht
        .Cells(1, 1).Value = sTxt
        .Cells(1, 2).Value = " : Text to Process"
        .Cells(2, 1).Value = sKey
        .Cells(2, 2).Value = " : Extended Key"
        .Cells(3, 1).Value = sAccum
        .Cells(3, 2).Value = sMode
        .Cells.Font.Name = "Consolas"
        .Columns("A:A").Select
    End With
    
    'make columns fit text length
    Selection.Columns.AutoFit
    oSht.Cells(1, 1).Select

End Sub

Function CheckInputs(sText As String) As Boolean
    'checks message and key for illegal characters
    'here intends use of capitals A-Z, ie ASCII 65-90
    'and integers 0-9, ie ASCII 48-57
    
    Dim nL As Long, n As Long
    Dim sSamp As String, nChr As Long
    
    'check for empty strings
    If sText = "" Then
        MsgBox "Empty parameter string - closing"
        Exit Function
    End If
    
    'test each character
    nL = Len(sText)
    For n = 1 To nL
        'get characters one by one
        sSamp = Mid$(sText, n, 1)
        'convert to ascii value
        nChr = Asc(sSamp)
        'filter
        Select Case nChr
            Case 65 To 90, 48 To 57
                'these are ok
            Case Else
                MsgBox "Illegal character" & vbCrLf & _
                "Only capital letters and integers are allowed; no symbols and no spaces"
                Exit Function
        End Select
    Next n
     
    CheckInputs = True

End Function
        
Function LongKey(sKey As String, nLM As Long) As String
    'makes a repeated key to match length of message
    'starting from the user's key string
    'used in both encryption and decryption
    
    Dim nLK As Long, n As Long, m As Long
    Dim p As Long, sAccum As String
    
    'make long key
    nLK = Len(sKey)
    'if key is longer than message
    If nLK >= nLM Then
        LongKey = Left$(sKey, nLM) 'trim key to fit
        Exit Function
    Else 'message is assumed longer than key
        n = Int(nLM / nLK) 'number of repeats needed
        m = nLM - (n * nLK) 'number of additional characters
        For p = 1 To n
            sAccum = sAccum & sKey
        Next p
        sAccum = sAccum & Left$(sKey, m) 'add any end characters
    End If
    
    LongKey = sAccum

End Function

Function CharaToMod36(sC As String) As Long
    'gets the modulo-36 value of the input character
    'as it exists in the working set
    'For example range A to Z becomes 0 to 25
    'and 0 to 9 become 26 to 35
    
    Dim nASC As Long
    
    'get ascii value of character
    nASC = Asc(sC)
    
    'align charas to working set
    Select Case nASC
    Case 65 To 90
        'subtract 65 to convert to zero based set
        CharaToMod36 = nASC - 65
    Case 48 To 57
        'subtract 22 to convert to zero based set
        CharaToMod36 = nASC - 22
    End Select

End Function

Function Mod36ToChara(nR As Long) As String
    'gets the character for a mod-36 value
    'For example range 0 to 25 becomes A to Z
    'and 26 to 35 become 0 to 9
       
    Select Case nR
    Case 0 To 25 'cap letters, A-Z
        Mod36ToChara = Chr(nR + 65)
    Case 26 To 35 'integers, 0-9
        Mod36ToChara = Chr(nR + 22)
    Case Else
        MsgBox "Illegal character in Mod36ToChara"
        Exit Function
    End Select

End Function

Function AddMod36(nT As Long, nB As Long) As Long
    'adds two positive integers to mod-36, ie set 0-35,
    'that is, no output can exceed 35
            
    Dim nSum As Long
    
    If nT >= 0 And nT < 36 And nB >= 0 And nB < 36 Then
        'inputs are all ok
    Else
        MsgBox "Parameters out of bounds in AddMod36"
    End If
        
    nSum = nT + nB
    
    AddMod36 = nSum Mod 36

End Function

Function SubMod36(nT As Long, nB As Long) As Long
    'subtracts nB from nT mod-36
    'that is, no output can be negative or exceed 25
    'Returns negative results as positive by adding 26
    
    Dim nDif As Long
    
    If nT >= 0 And nT < 36 And nB >= 0 And nB < 36 Then
        'inputs are all ok
    Else
        MsgBox "Parameters out of bounds in SubMod36"
    End If
    
    nDif = nT - nB 'possibly negative
    
    If nDif < 0 Then
        nDif = nDif + 36
    End If
        
    SubMod36 = nDif

End Function

Sub Notes()
    'Notes on the code
    
    'A to Z, correspond to character set positions 0 to 25.
    '0 to 9, correspond to character set positions 26 to 35.
    'The modulus for addition and subtraction is therefore 36.
    'Negative results in caculation are made positive by adding 36.
    'Positive results in calculation greater than 35 are reduced by 36.
    
    'ASCI values made calculation simple here but a more general version could
    'preload any character set for lookup with alternative coding.
        
    'See Wikibooks text for a table image and further details.

End Sub

See Also[edit]



Error Handling

Summary[edit]

The code module below shows one layout method for error handling. It uses a bit more space than the usual thing but has good clarity. It also includes error logging and a block for testing the code by raising errors. Only a few errors have been listed.

Notice that no formatting is done in the log writing procedure itself, and that a choice of block logs with line separation or serial logs with comma-separation are both included.

VBA Code[edit]

Option Explicit

Sub ErrorCodeShell()
    'time saving errors code shell
   

On Error GoTo ERR_HANDLER
    
    '===================================
    'Main body of procedure goes here...
    '===================================
    
    '===================================
    '   Raise Errors Here For Testing
    '===================================
    'Err.Raise 6  'overflow
    Err.Raise 11 'div zero
    'Err.Raise 53 'file not found
    'Err.Raise 70 'permission denied
    '===================================
    
    Exit Sub
ERR_HANDLER:
    If Err.Number <> 0 Then
        'LOG ERROR DETAILS
        
        'make error messages
        Dim sE1 As String, sE2 As String
        Dim oErr1 As ErrObject, oErr2 As ErrObject
        
        'make error messages
        Set oErr1 = Err: Set oErr2 = Err
        sE1 = Message1(oErr1) 'block style message
        sE2 = Message2(oErr2) 'serial style
        Set oErr1 = Nothing: Set oErr2 = Nothing
                
        'enable logging as block or serial format
        LogError3 sE1   'write to log block style
        'LogError3 sE2   'write to log serial style
                
        'write to immediate window
        Debug.Print sE1 'block style
        'Debug.Print sE2 'serial style
        
        'selective error handling
        Select Case Err.Number
        Case 53
            GoTo FileNotFound
        Case 70
            GoTo PermissionDenied
        Case Else:
            GoTo OtherErrors
        End Select
FileNotFound:
        'Handle the error
        Err.Clear
        Exit Sub
PermissionDenied:
        'Handle the error
        Err.Clear
        Exit Sub
OtherErrors:
        MsgBox sE1
        Err.Clear
        Exit Sub
    End If

End Sub

Function LogError3(sIn As String) As Boolean
    'logs parameter string to a text file
    'assumes same path as calling Excel workbook
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim sPath As String, Number As Integer
    
    Number = FreeFile 'Get a file number
    sPath = ThisWorkbook.Path & "\error_log3.txt" 'modify path\name here
    
    Open sPath For Append As #Number
    Print #Number, sIn
    Close #Number

    LogError3 = True
            
End Function

Function Message1(oE As ErrObject) As String
    'makes block style message for error
    
    Dim sEN As String, sSrc As String
    Dim sDesc As String, sDT As String
    
    'make date-time string
    sDT = Format(Now, "d mmm yyyy") & ", " & _
                   Format(Now, "dddd hh:mm:ss AMPM")
    
    'get error parts
    sEN = CStr(oE.Number)   'number of error
    sSrc = oE.Source        'source of error
    sDesc = oE.Description  'description of error
    
    'make block message with line separations
    Message1 = sDT & vbNewLine & _
        "Error number: " & sEN & vbNewLine & _
        "Source: " & sSrc & vbNewLine & _
        "Description: " & sDesc & vbNewLine

End Function

Function Message2(oE As ErrObject) As String
    'makes serial style message for error
    
    Dim sEN As String, sSrc As String
    Dim sDesc As String, sDT As String
    
    'make date-time string
    sDT = Format(Now, "dddd yyyy mmm d hh:mm:ss")
    
    'get error parts
    sEN = CStr(oE.Number)   'number of error
    sSrc = oE.Source        'source of error
    sDesc = oE.Description  'description of error
    
    'make serial message with comma separations
    Message2 = sDT & ",Error " & sEN & "," & sSrc & "," & sDesc

End Function

See Also[edit]

External Links[edit]



File and Folder Dialogs

Summary[edit]

At times we need to access files and folders to provide input for procedures, and the code below will do this. They are not much different to the dialogs that Windows uses, and each of them works by returning a full path string to the chosen item. When a folder is selected, the returned string does not include the end backslash; the user needs to add that himself.

Only one file selection dialog is given, and no significant fault can be found with it. Two folder dialogs are included, one in the same family as the file dialog and the other based on an API. (Credit to Chip Pearson.) These two look a bit different in use, so it is left to the user to choose between them. All three can be run from the test procedure.

Just copy the entire code listing into a standard module for use.

VBA Code Module[edit]

The default file-type listing that opens in SelectFile() is decided by which of the Filters.Add code lines appears first in the sequence. For example, to have the All Files as your prefered listing, just move that line so that it immediately follows the Filters Clear line. Of course, the listing can also be changed by selecting the drop menu while the dialog is open.

Option Explicit
Option Private Module
Option Compare Text
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' API version code credit to Chip Pearson at http://www.cpearson.com/excel/browsefolder.aspx
    ' This contains the BrowseFolder function, which displays the standard Windows Browse For Folder
    ' dialog. It returns the complete path of the selected folder or vbNullString if the user cancelled.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Private Const BIF_RETURNONLYFSDIRS As Long = &H1
    Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
    Private Const BIF_RETURNFSANCESTORS As Long = &H8
    Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
    Private Const BIF_BROWSEFORPRINTER As Long = &H2000
    Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
    
    
    Private Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszINSTRUCTIONS As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
    
    
    Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, _
        ByVal pszBuffer As String) As Long
    
    Private Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As _
        BROWSEINFO) As Long
    
    
    Private Const MAX_PATH = 260 ' Windows mandated

Sub TestBrowseFilesAndFolders()
    
    Dim sRet As String
    
    'run to test the file selection dialog
    sRet = SelectFile("Select a file...")
    
    'run to test the folder selection dialog
    'sRet = SelectFolder("Select a folder...")
    
    'run to test the API folder selection dialog
    'sRet = BrowseFolder("Select a folder...")
    
    MsgBox sRet

End Sub

Function BrowseFolder(Optional ByVal DialogTitle As String = "") As String
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' BrowseFolder
    ' This displays the standard Windows Browse Folder dialog. It returns
    ' the complete path name of the selected folder or vbNullString if the
    ' user cancelled.   Returns without and end backslash.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    If DialogTitle = vbNullString Then
        DialogTitle = "Select A Folder..."
    End If
    
    Dim uBrowseInfo As BROWSEINFO
    Dim szBuffer As String
    Dim lID As Long
    Dim lRet As Long
    
    
    With uBrowseInfo
        .hOwner = 0
        .pidlRoot = 0
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = DialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS ' + BIF_USENEWUI
        .lpfn = 0
    End With
    szBuffer = String$(MAX_PATH, vbNullChar)
    lID = SHBrowseForFolderA(uBrowseInfo)
    
    If lID Then
        ''' Retrieve the path string.
        lRet = SHGetPathFromIDListA(lID, szBuffer)
        If lRet Then
            BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
        End If
    End If

End Function

Function SelectFolder(Optional sTitle As String = "") As String
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    'Returns path string without an end backslash.
    
    Dim sOut As String
        
    With Application.FileDialog(msoFileDialogFolderPicker)
        'see also msoFileDialogFolderPicker, msoFileDialogOpen, and msoFileDialogSaveAs
        'uses Excel's default opening path but any will do
        'needs the backslash in this case
        .InitialFileName = Application.DefaultFilePath & " \ "
        .Title = sTitle
        .Show
        If .SelectedItems.Count = 0 Then
            'MsgBox "Canceled without selection"
        Else
            sOut = .SelectedItems(1)
            'MsgBox sOut
        End If
    End With

    SelectFolder = sOut

End Function

Function SelectFile(Optional sTitle As String = "") As String
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    
    Dim fd As FileDialog, sPathOnOpen As String, sOut As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'do not include backslash here
    sPathOnOpen = Application.DefaultFilePath
    
    'set the file-types list on the dialog and other properties
    With fd
        .Filters.Clear
        .Filters.Add "Excel workbooks", "*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
        .Filters.Add "Word documents", "*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
        .Filters.Add "All Files", "*.*"
        
        .AllowMultiSelect = False
        .InitialFileName = sPathOnOpen
        .Title = sTitle
        .InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
        .Show
        
        If .SelectedItems.Count = 0 Then
            'MsgBox "Canceled without selection"
            Exit Function
        Else
            sOut = .SelectedItems(1)
            'MsgBox sOut
        End If
    End With
    
    SelectFile = sOut

End Function

See Also[edit]

External Links[edit]

  • BrowseFolder : Chip Pearson's page on the API folder browser.
  • FileDialog Properties and Methods: The Microsoft documentation for the FileDialog selection methods. It includes a code panel showing the use of file multi-selection.



Recursive File Listing of Folders

Summary[edit]

  • Recursive listings are tricky, and it is found to be difficult without module or public declarations of some sort. This version although a bit clumsy will perform as expected for files that can be accessed.
  • A public variable is used as a counter to keep track, between iterations, of the numbers of files found, since Microsoft advises us that static variables are not usually used with recursion. The VBA code is not specific for any particular Office application, so would work in say MS Excel or MS Word etc.
  • The user might need to introduce more filtering; for example, to exclude certain file types, or to avoid those of zero size. A comment in the code listing shows where such a code function could be added to the existing condition.
  • Because the array is public, it can be accessed from any other module for its further processing or output. Copy the code entirely into a code module, and modify the folder and recursion condition to your own values.
  • My Documents versus Documents. There are four virtual folders in Libraries, My Documents, My Music, My Pictures, and My Videos. When the Windows Explorer's Folder Options forbid the display of hidden files, folders, and drives, the correct locations are returned by various folder selection dialogs, namely Documents, Music, Pictures, and Videos. When hidden folders are permitted, then dialogs and listings will attempt to make use of these virtual paths. Access violations will result. To avoid undue problems, check that your folder options are set not to show hidden files or folders. This procedure avoids these folders altogether, but access violations can be avoided, provided that hidden files are allowed to stay hidden.

VBA Code[edit]

Option Explicit
Option Base 1

Public vA() As String
Public N As Long


Sub MakeList()
    'loads an array with details of the files in the selected folder.
    
    Dim sFolder As String, bRecurse As Boolean
    
    'NOTE
    'The Windows virtual folders My Music, My Videos, and My Pictures
    'generate (handled) error numbers 70,90,91 respectively, so are avoided.
    'Alternatively, set Folder Options to not show hidden files and folders
    'to avoid the problem.
    
    'set folder and whether or not recursive search applies
    sFolder = "C:\Users\My Folder\Documents\Computer Data\"
    bRecurse = True

    'erase any existing contents of the array
    Erase vA()  'public string array
        
    'this variable will accumulate the result of all recursions
    N = 0 'initialize an off-site counting variable
            
    'status bar message for long runs
    Application.StatusBar = "Loading array...please wait."
    
    'run the folder proc
    LoadArray sFolder, bRecurse
        
    If N = 0 Then
       Application.StatusBar = "No Files were found!"
       MsgBox "NO FILES FOUND"
       Application.StatusBar = ""
       Exit Sub
    Else
       'status bar message for long runs
       Application.StatusBar = "Done!"
       MsgBox "Done!" & vbCrLf & N & " Files listed."
       Application.StatusBar = ""
       Exit Sub
    End If

End Sub

Sub LoadArray(sFolder As String, bRecurse As Boolean)
    'loads dynamic public array vA() with recursive or flat file listing
       
    'The Windows folders My Music, My Videos, and My Pictures
    'generate error numbers 70,90,91 respectively, and are best avoided.
    
    Dim FSO As Object, SourceFolder As Object, sSuff As String, vS As Variant
    Dim SubFolder As Object, FileItem As Object, sPath As String
    Dim r As Long, Count As Long, m As Long, sTemp As String
    
    'm counts items in each folder run
    'N (public) accumulates m for recursive runs
    m = m + N
        
    On Error GoTo Errorhandler
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(sFolder)
    
    For Each FileItem In SourceFolder.Files
        DoEvents
        sTemp = CStr(FileItem.Name)
        sPath = CStr(FileItem.path)
        
        'get suffix from fileitem
        vS = Split(CStr(FileItem.Name), "."): sSuff = vS(UBound(vS))
        
        If Not FileItem Is Nothing Then 'add other file filter conditions to this existing one here
            m = m + 1 'increment this sourcefolder's file count
            'reset the array bounds
            ReDim Preserve vA(1 To 6, 0 To m)
            r = UBound(vA, 2)
                'store details for one file on the array row
                vA(1, r) = CStr(FileItem.Name)
                vA(2, r) = CStr(FileItem.path)
                vA(3, r) = CLng(FileItem.Size)
                vA(4, r) = CDate(FileItem.DateCreated)
                vA(5, r) = CDate(FileItem.DateLastModified)
                vA(6, r) = CStr(sSuff)
        End If
    Next FileItem
    
    'increment public counter with this sourcefolder count
    N = m  'N is public
    
    'this bit is responsible for the recursion
    If bRecurse Then
        For Each SubFolder In SourceFolder.SubFolders
            LoadArray SubFolder.path, True
        Next SubFolder
    End If
       
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Exit Sub

Errorhandler:
    If Err.Number <> 0 Then
        Select Case Err.Number
        Case 70 'access denied
            'MsgBox "error 70"
            Err.Clear
            Resume Next
        Case 91 'object not set
            'MsgBox "error 91"
            Err.Clear
            Resume Next
        Case Else
            'MsgBox "When m = " & m & " in LoadArray" & vbCrLf & _
            "Error Number :  " & Err.Number & vbCrLf & _
            "Error Description :  " & Err.Description
            Err.Clear
            Exit Sub 'goes to next subfolder - recursive
        End Select
    End If

End Sub



File and Folder Utilities

Summary[edit]

  • This first set of utilities concentrates on the basic FileSystemObject set; that is, the set used to find whether or not a file or folder exists, what their sizes are, and whether or not they have a particular attribute. A basic path parsing procedure is also provided. All of these procedures need a reference set in the VBA editor to Microsoft Scripting Runtime
  • No universally useful code was found for testing for open files. Although many procedures exist, they all fail in some way, usually failing to identify open text or image files, or Office files that are marked as read-only. The basis of the problem is that many such files in Windows do not lock when opened by a user, so procedures that attempt to detect the open state by trying for sole access, cannot do so. Any reader with a universal solution is, as always, invited to comment.

VBA Notes[edit]

At times it is useful to know whether or not a file or folder has a particular attribute, for example, to avoid hidden or system files in listings. The procedure HasAttribute does this, taking a path to the file as parameter and a short-code to identify the attribute of interest. However, the attribute bundle is delivered with all of the attribute number values added together, so this type of test, like other enumerations that involve constants (eg; the message box types), makes use of the AND function to split the bundle.

For example: (See procedure HasAttribute below.) Assume that the attribute bundle from GetAttr equals 37
and that we are testing for the "system" attribute only ("S") with vbSystem = 4. Now, for numbers,
the AND operator performs a bitwise AND on each column, so gives:

01001012 = 3710 = vbArchive + vbSystem + vbReadOnly
00001002 = 410 = vbSystem
_______
00001002 = 410, interpreted by boolean variables as True since it is non-zero

That is to say, the "system" attribute is present in the attribute bundle.
If the "system" attribute were not set, then the result would have been all zeros

It is important to note that the returned value tests only one attribute at a time; that is to say, although a file returns true for for read-only ("R"), it might also have other attributes that are not tested. If users would rather have all of the file or folder attributes returned in one string, some work might be done to concatenate the result codes.

An example of file path parsing is given in the ParsePath procedure. The example uses the Split function to place all of the backslash separated terms into an array, then recombines them to make the path. A similar method, split on the dot is used to make the file name and suffix.

VBA Code Module[edit]

Option Explicit

Function FileFound(sPath As String) As Boolean
    'returns true if parameter path file found
    
    Dim fs As FileSystemObject
          
    'set ref to fso
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'test for file
    FileFound = fs.FileExists(sPath)
        
    Set fs = Nothing
    
End Function

Function FolderFound(sPath As String) As Boolean
    'returns true if parameter path folder found
    
    Dim fs As FileSystemObject
          
    'set ref to fso
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'test for folder
    FolderFound = fs.FolderExists(sPath)
        
    Set fs = Nothing
    
End Function

Function GetFileSize(sPath As String, nSize As Long) As Boolean
    'returns file size in bytes for parameter path file
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sPath) Then
        Set f = fs.GetFile(sPath)
        nSize = f.Size
        GetFileSize = True
    End If

    Set fs = Nothing: Set f = Nothing

End Function

Function GetFolderSize(sPath As String, nSize As Long) As Boolean
    'returns total content size in bytes for parameter path folder
    
    Dim fs As FileSystemObject, f As Folder
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FolderExists(sPath) Then
        Set f = fs.GetFolder(sPath)
        nSize = f.Size
        GetFolderSize = True
    End If
    
    Set fs = Nothing: Set f = Nothing

End Function

Function HasAttribute(sPath As String, sA As String) As Boolean
    'returns true if parameter path file or folder INCLUDES test parameter
    'eg: if sA= "H" then returns true if file attributes INCLUDE "hidden"
    'Untested attributes might also exist
    
    'sA values
    '"R"; read only, "H"; hidden, "S"; system, "A"; archive
    '"D"; directory, "X"; alias, "N"; normal
        
    Dim bF As Boolean, nA As Integer
    Dim bFile As Boolean, bFldr As Boolean
    Dim fs As FileSystemObject, f As File, fd As Folder
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'check path parameter
    bFile = fs.FileExists(sPath)
    bFldr = fs.FolderExists(sPath)
    
    If bFile Or bFldr Then
        'get its attribute bundle
        nA = GetAttr(sPath)
    Else
        'neither found so exit
        MsgBox "Bad path parameter"
        GoTo Wayout
    End If
        
    'early exit for no attributes
    If nA = 0 And sA = "N" Then                   '0
        HasAttribute = True
        Exit Function
    End If
    
    'test for attribute in sA
    'logical AND on number variable bit columns
    If (nA And vbReadOnly) And sA = "R" Then      '1
        bF = True
    ElseIf (nA And vbHidden) And sA = "H" Then    '2
        bF = True
    ElseIf (nA And vbSystem) And sA = "S" Then    '4
        bF = True
    ElseIf (nA And vbDirectory) And sA = "D" Then '16
        bF = True
    ElseIf (nA And vbArchive) And sA = "A" Then   '32
        bF = True
    ElseIf (nA And vbAlias) And sA = "X" Then     '64
        bF = True
    End If
    
    HasAttribute = bF

Wayout:
    Set fs = Nothing: Set f = Nothing: Set fd = Nothing

End Function

Function ParsePath(sPath As String, Optional sP As String, _
                   Optional sF As String, Optional sS As String) As Boolean
    'sPath has full file path
    'returns path of file with end backslash (sP),
    'file name less suffix (sF), and suffix less dot(sS)
    
    Dim vP As Variant, vS As Variant, n As Long
    Dim bF As Boolean, fs As FileSystemObject
        
    'set ref to fso
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'test that file exists
    bF = fs.FileExists(sPath)

    If Not bF Then
        'MsgBox "File not found"
        GoTo Wayout
    End If
        
    'make array from path elements split on backslash
    vP = Split(sPath, "\")
    
    'make array from file name elements split on dot
    vS = Split(vP(UBound(vP)), ".")

    'rebuild path with backslashes
    For n = LBound(vP) To UBound(vP) - 1
        sP = sP & vP(n) & "\"
    Next n
     
    sF = vS(LBound(vS))
    sS = vS(UBound(vS))

    ParsePath = True

Wayout:
    Set fs = Nothing

End Function

See Also[edit]

External Links[edit]



Font Utilities

Summary[edit]

  • This page lists VBA procedures that are mainly to do with fonts. That is to say, how VBA handles fonts.
  • The function GetTextPoints() finds the width of text in points. A label on a userform extends when loaded with the string. The width is then read from the control. The userform and its contents are loaded but never shown. Despite its seeming lack of elegance, this method is perhaps the simplest way of getting the fitting width for text, correct for any variation in the font. The function is useful in the precise sizing of controls for complex layouts, such as tables within text boxes.
  • The procedure ListAllExcelFonts() lists Excel's fonts on a worksheet. It makes use of GetTextPoints(). While listing whether or not the font is monospaced, it also makes a sample of test text in each font. It also lists the width in points for the sample text in each font. Normalizing these width figures might be more useful but it is unclear as to which font is best to represent the standard. As ever, informed comments would be useful.
  • The procedure FontExists() tests whether or not a font exists. It returns true in the function name if the parameter font name exists, otherwise it returns false. Run testit() to try the function.

Font Tests[edit]

The function GetTextPoints() can be used to determine whether or not a font is monospaced. Although at first sight it would appear suitable for determining the presence of kerning, the userform control used to measure the width of text does not kern the text applied to it in any case. As such, kerning will always be found to be absent. The tests, whether used visually or in an automated mode, compare the lengths of selected strings. If the strings of the first pair below are the same length, then the font is monospaced. Elsewhere, if kerning had been applied, then the strings of the second pair would be different in length.

Monospace test strings:
IIIIIIIIII
HHHHHHHHHH

Kerning test strings: for completeness only.
AAAAATTTTT
ATATATATAT

Code Module Notes[edit]

Code Module[edit]

Revisions[edit]

Sub TestGetTextPoints()
    'Run this to obtain the points width of text
    
    ' Get the net width in points for the string
    MsgBox GetTextPoints("The quick brown fox jumps over the lazy dog", "Consolas", 12, 0, 0) & _
                         " points width"
End Sub

Function GetTextPoints(sIn As String, sFontName As String, _
    nFontSize As Single, bFontBold As Boolean, _
    bFontItalic As Boolean) As Long
    'GetTextPoints returns points width of text.
    'When setting a control width, add two additional
    'space widths to these values to avoid end clipping.
    'Needs a user form called CountPoints. Form
    'is loaded and unloaded but never shown.
        
    'Monospace test: could be used here to identify monospaced fonts
    'If pair is same width then monospaced
    'IIIIIIIIII
    'HHHHHHHHHH
    
    'Kerning test pair used by printers: Wont work here since there is no kerning in userform controls.   
    'If pair are different width then there is kerning.
    'AAAAATTTTT
    'ATATATATAT

    Dim oLbl As Control
    
    Load CountPoints
    Set oLbl = CountPoints.Controls.Add("Forms.Label.1", "oLbl")

    'format the label with same fonts as sIn
    With oLbl
        .Width = 0
        .WordWrap = False
        .Visible = False
        .AutoSize = True
        .Caption = ""
        .font.SIZE = nFontSize
        .font.Name = sFontName
        .font.Bold = bFontBold
        .font.Italic = bFontItalic
    End With

    'get points for sIn
    oLbl.Caption = sIn
    GetTextPoints = oLbl.Width

    Unload CountPoints

End Function

Sub ListAllExcelFonts()
    'Lists Excel fonts as monospaced or proportional
    'with a sample of text and its width in points
    'calls GetTextPoints to measure test strings
    'needs use of Sheet1 - clears all existing
    
    Dim FontList, sht As Worksheet, i As Long
    Dim sM1 As String, sM2 As String, sFN As String
    Dim sTest As String, nSize As Single
    Dim bBold As Boolean, bItalic As Boolean
    
    'monospaced test strings
    sM1 = "IIIIIIIIII"
    sM2 = "MMMMMMMMMM"
    
    'set a suitable test string here
    sTest = "The quick brown fox jumps over the lazy dog 1234567890"
    
    'set test parameters
    nSize = 10 'ten point for all tests
    bBold = False
    bItalic = False
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    With sht
        .Activate
        .Range("A1:Z65536").ClearContents
        .Range("A1:Z65536").ClearFormats
    End With
    
    'get reference to the font list
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
    
    On Error Resume Next
    'work loop
    For i = 1 To FontList.ListCount
        
        sFN = FontList.List(i) 'font name
        
        'print general data to sheet
        With sht
            .Cells(i, 1) = sFN                                              'name
            .Cells(i, 3) = GetTextPoints(sTest, sFN, nSize, bBold, bItalic) 'test string pts width
        End With
        
        'set fonts for sample cell
        With sht.Cells(i, 4).font
            .Name = sFN
            .SIZE = nSize
            .Italic = bItalic
            .Bold = bBold
        End With
        
        'sample string to sheet
        sht.Cells(i, 4) = sTest
        
        'monospaced  test - true if both test strings equal in length
        If GetTextPoints(sM1, sFN, nSize, bBold, bItalic) = GetTextPoints(sM2, sFN, nSize, bBold, bItalic) Then
            'the test font is monospaced
            sht.Cells(i, 2) = "Monospaced"  'mono or prop
        Else
            sht.Cells(i, 2) = "Proportional"
        End If
    Next i
        
    With sht
        .Columns.AutoFit
        .Cells(1, 1).Select
    End With

End Sub

Private Sub testit()
    ' Find whether or not a font exists
    Dim sFontName As String
    
    sFontName = "Consolas"
    
    If FontExists(sFontName) Then
        MsgBox sFontName & " exists"
    Else
        MsgBox sFontName & " does not exist"
    End If

End Sub

Public Function FontExists(FontName As String) As Boolean
    ' Returns true in function name
    ' if parameter font name exists
    
    Dim oFont As New StdFont
    
    oFont.Name = FontName
    If StrComp(FontName, oFont.Name, vbTextCompare) = 0 Then
        FontExists = True
    End If
    
End Function

See Also[edit]

External Links[edit]



The Elusive Button

Summary[edit]

These VBA code modules are intended for Microsoft Excel. They show how to make a button that continually escapes attempts to click it. The code needs only a user form called UserForm1, and two command buttons, CommandButton1 and CommandButton2; The code will size the controls and the form itself.

Code Notes[edit]

  • The MouseMove event applies to specific controls; in this case a CommandButton. It fires whenever the mouse moves anywhere within the area of the control, and is used here to move the control before the user can select it.
  • The code proposes random direction and shift amounts, then checks to make sure that the resulting shift will stay on the form, before moving the control. When a proposed shift is rejected, the fact that the mouse is still moving ensures that another event will still fire before a selection can be made. Selection HAS been known to happen, perhaps when there is an unlikely number of rejected shift values; a click procedure has been included to note the fact, just in case.
  • The VBA help page for this event has an impressive set of options, as yet unexplored here.

The ThisWorkbook Module[edit]

Copy this code into the ThisWorkbook module of the project. Save the file as xlsm type. It will run whenever the file is opened.

Private Sub Workbook_Open()
   'loads the user form at file open
   
   Load UserForm1
   UserForm1.Show

End Sub

The Userform1 Module[edit]

Copy this code into the UserForm1 module. It can be accessed by double-clicking the userform in design mode. Save the file, making sure it is xlsm type. The code is run by opening the file or by clicking the above Open event procedure in the ThisWorkbook module.

Code Modifications[edit]

Added colors and overlaps, 2 Feb 2019
Added notes to code, 2 Feb 2019

Option Explicit

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, _
            ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'Runs whenever the mouse moves anywhere on the CommandButton control.
    'Shifts the control when that happens, provided that the proposed
    'random shift will still allow the control to stay on the form.
        
    Dim Lrand1 As Long, Lrand2 As Long, Lstartval As Single, LMyrand As Long
    Dim Trand1 As Long, Trand2 As Long, Tstartval As Single, TMyrand As Long
    
    'propose random horizontal jump direction and distance
    Lrand1 = 1 'direction
    Lstartval = Rnd 'fractional
    If Lstartval < 0.5 Then Lrand1 = -1
        Lrand2 = Int((70 - 45 + 1) * Rnd + 45) 'distance
        LMyrand = Lrand1 * Lrand2 'direction and distance
     
    'propose random vertical jump direction and distance
    Trand1 = 1 'direction
    Tstartval = Rnd 'fractional
    If Tstartval < 0.5 Then Trand1 = -1
        Trand2 = Int((70 - 45 + 1) * Rnd + 45) 'distance
        TMyrand = Trand1 * Trand2 'direction and distance
    
    With CommandButton1
        Select Case Lrand1
        Case 1 'positive shift to right
            'if shift still on userform...
            If .Left + LMyrand + .Width < UserForm1.Width + 10 Then
               .Left = .Left + LMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        Case -1 'negative shift to left
            'if shift still on userform...
            If .Left + LMyrand > -10 Then
               .Left = .Left + LMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        End Select
    
        Select Case Trand1
        Case 1 'positive shift down
            'if shift still on userform...
            If .Top + TMyrand + .Height < UserForm1.Height + 10 Then
               .Top = .Top + TMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        Case -1 'negative shift up
            'if shift still on userform...
            If .Top + TMyrand > -10 Then
               .Top = .Top + TMyrand 'shift
            Else
               'do nothing - will fire again
            End If
        End Select
    End With

End Sub

Private Sub CommandButton1_Click()
    'runs if user can select button
    'Rare, but it can happen
    
    MsgBox "It had to happen sometime!"
    
End Sub

Private Sub CommandButton2_Click()
    'runs from alternative choice
    'to stop process and unload form
    
    UserForm1.Hide
    Unload UserForm1

End Sub

Private Sub UserForm_Initialize()
    'runs after loading but before show
    'sets initial values of form and controls
    
    With UserForm1
        .Height = 250
        .Width = 250
        .BackColor = RGB(9, 13, 147)
        .Caption = "Ambitious?..."
    End With
    With CommandButton1
        .Height = 55
        .Width = 55
        .Top = 45
        .Left = 55
        .BackColor = RGB(255, 172, 37)
        .Caption = "Press if" & vbCrLf & "you want" & vbCrLf & "a raise"
    End With
    With CommandButton2
        .Height = 55
        .Width = 55
        .Top = 45
        .Left = 140
        .BackColor = RGB(222, 104, 65)
        .Caption = "No thanks?"
    End With
End Sub

See Also[edit]

{bookcat}



String Hashing in VBA

Summary[edit]

  • The VBA code below generates the digests for the MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes; in this case for strings.
  • A hash is an output string that resembles a pseudo random sequence, and is essentially unique for any string that is used as its starting value. Hashes cannot be easily cracked to find the string that was used in their making and they are very sensitive to input change. That is to say, just a change in one character at the start will produce a completely different output. Hashes can be used as the basis of pseudo random character tables, and although not purely random, such methods can produce output quality that is at least as good as the in-built Rnd() function of VBA..
  • The use of a hash allows programmers to avoid the embedding of password strings in their code.
    • The memory space occupied by an application can be read with special utilities, so passwords might be be found in code, then used in a normal user login. Instead, the hash of the password is listed in code, and the password is hashed for comparison only during a logon. This avoids access to the application via the conventional user route, since any hash that is found could not be reverse engineered to obtain the value needed at the user interface. This method assumes that the code cannot be run by the intruder at any location other than the logon device, and that they are unable to change the memory contents.
    • If a hacker can change the memory contents, then a common exploit is to change the hash in memory for one of their own; one that corresponds to a password that they can use at the user logon interface. The counter action against this attack is for all of the logon files to be encrypted with the user's officially issued password. Then, even if the hash is changed, the files needed for the logon attempt cannot be decrypted for use.
  • Hashes can also be made from entire files, and the code for doing so differs only slightly from the string hashing versions given below. The main difference in file hashing is that the file is first turned into a string before using conventional techniques. Code is given elsewhere in this series for file hashing. String hashes will produce an output even when the empty string is used as a starting point, unlike for file hashing where an empty text file can raise errors.
  • This VBA code is not specific for any one application, so it will work in any of say, MS Word, MS Excel, or MS Access. These code versions include options for base-64 output or hex.

Code Listings[edit]

Notes on the Code[edit]

The VBA code below generates the digests for the MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes, for strings, in either of the hex or base-64 output formats. These codings each make use of MS Office's built-in functions, and provide consistent results. It has been noted that original implementations elsewhere for the same digests can differ widely in their outputs. Only one example has been given with a seed or salt parameter (StrToSHA512Salt), and it should be noted that the HMACSHA512 class output differs from the SHA*Managed class hashes given in the remainder. The Managed classes give the best widely reported results. Note the VBA references required for correct operation. A reminder of these is given in some procedure headings.

In each case, coders can find the unmodified hash values in the bytes() array and at that point they are in 8-bit bytes, that is, the numbers that represent the ASCI code as it applies to a full eight-bit, 256 character set. The code that follows the filling of the bytes() array in each case decides which version of the ASCI character set to deliver. For a hex set of characters, 0-9, and A to F, the total bit set is broken into double the number of four-bit bytes, then returned for use. For the base-64 set, lower case letters,upper case letters, and integers mainly, six bit characters are made for output. These two sets are the most useful here, since they consist of commonly used characters. The 128 and 256 ASCI sets are too full of both exotic and non-printing characters to be useful. For each hash version its bit count is a constant, so the length of its output will vary according to the chosen type.

Option Explicit

Sub Test()
    'run this to test md5, sha1, sha2/256, sha384, sha2/512 with salt, or sha2/512
    Dim sIn As String, sOut As String, b64 As Boolean
    Dim sH As String, sSecret As String
    
    'insert the text to hash within the sIn quotes
    'and for selected procedures a string for the secret key
    sIn = ""
    sSecret = "" 'secret key for StrToSHA512Salt only
    
    'select as required
    'b64 = False   'output hex
    b64 = True   'output base-64
    
    'enable any one
    'sH = MD5(sIn, b64)
    'sH = SHA1(sIn, b64)
    'sH = SHA256(sIn, b64)
    'sH = SHA384(sIn, b64)
    'sH = StrToSHA512Salt(sIn, sSecret, b64)
    sH = SHA512(sIn, b64)
    
    'message box and immediate window outputs
    Debug.Print sH & vbNewLine & Len(sH) & " characters in length"
    MsgBox sH & vbNewLine & Len(sH) & " characters in length"
    
    'de-comment this block to place the hash in first cell of sheet1
'    With ThisWorkbook.Worksheets("Sheet1").Cells(1, 1)
'        .Font.Name = "Consolas"
'        .Select: Selection.NumberFormat = "@" 'make cell text
'        .Value = sH
'    End With

End Sub

Public Function MD5(ByVal sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    
    'Test with empty string input:
    'Hex:   d41d8cd98f00...etc
    'Base-64: 1B2M2Y8Asg...etc
        
    Dim oT As Object, oMD5 As Object
    Dim TextToHash() As Byte
    Dim bytes() As Byte
        
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
 
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oMD5.ComputeHash_2((TextToHash))
 
    If bB64 = True Then
       MD5 = ConvToBase64String(bytes)
    Else
       MD5 = ConvToHexString(bytes)
    End If
        
    Set oT = Nothing
    Set oMD5 = Nothing

End Function

Public Function SHA1(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    
    'Test with empty string input:
    '40 Hex:   da39a3ee5e6...etc
    '28 Base-64:   2jmj7l5rSw0yVb...etc
    
    Dim oT As Object, oSHA1 As Object
    Dim TextToHash() As Byte
    Dim bytes() As Byte
            
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA1 = CreateObject("System.Security.Cryptography.SHA1Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA1.ComputeHash_2((TextToHash))
        
    If bB64 = True Then
       SHA1 = ConvToBase64String(bytes)
    Else
       SHA1 = ConvToHexString(bytes)
    End If
            
    Set oT = Nothing
    Set oSHA1 = Nothing
    
End Function

Public Function SHA256(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    
    'Test with empty string input:
    '64 Hex:   e3b0c44298f...etc
    '44 Base-64:   47DEQpj8HBSa+/...etc
    
    Dim oT As Object, oSHA256 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA256.ComputeHash_2((TextToHash))
    
    If bB64 = True Then
       SHA256 = ConvToBase64String(bytes)
    Else
       SHA256 = ConvToHexString(bytes)
    End If
    
    Set oT = Nothing
    Set oSHA256 = Nothing
    
End Function

Public Function SHA384(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    
    'Test with empty string input:
    '96 Hex:   38b060a751ac...etc
    '64 Base-64:   OLBgp1GsljhM2T...etc
    
    Dim oT As Object, oSHA384 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA384 = CreateObject("System.Security.Cryptography.SHA384Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA384.ComputeHash_2((TextToHash))
    
    If bB64 = True Then
       SHA384 = ConvToBase64String(bytes)
    Else
       SHA384 = ConvToHexString(bytes)
    End If
    
    Set oT = Nothing
    Set oSHA384 = Nothing
    
End Function

Public Function SHA512(sIn As String, Optional bB64 As Boolean = 0) As String
    'Set a reference to mscorlib 4.0 64-bit
    
    'Test with empty string input:
    '128 Hex:   cf83e1357eefb8bd...etc
    '88 Base-64:   z4PhNX7vuL3xVChQ...etc
    
    Dim oT As Object, oSHA512 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA512 = CreateObject("System.Security.Cryptography.SHA512Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA512.ComputeHash_2((TextToHash))
    
    If bB64 = True Then
       SHA512 = ConvToBase64String(bytes)
    Else
       SHA512 = ConvToHexString(bytes)
    End If
    
    Set oT = Nothing
    Set oSHA512 = Nothing
    
End Function

Function StrToSHA512Salt(ByVal sIn As String, ByVal sSecretKey As String, _
                           Optional ByVal b64 As Boolean = False) As String
    'Returns a sha512 STRING HASH in function name, modified by the parameter sSecretKey.
    'This hash differs from that of SHA512 using the SHA512Managed class.
    'HMAC class inputs are hashed twice;first input and key are mixed before hashing,
    'then the key is mixed with the result and hashed again.
    
    Dim asc As Object, enc As Object
    Dim TextToHash() As Byte
    Dim SecretKey() As Byte
    Dim bytes() As Byte
    
    'Test results with both strings empty:
    '128 Hex:    b936cee86c9f...etc
    '88 Base-64:   uTbO6Gyfh6pd...etc
    
    'create text and crypto objects
    Set asc = CreateObject("System.Text.UTF8Encoding")
    
    'Any of HMACSHAMD5,HMACSHA1,HMACSHA256,HMACSHA384,or HMACSHA512 can be used
    'for corresponding hashes, albeit not matching those of Managed classes.
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA512")

    'make a byte array of the text to hash
    bytes = asc.Getbytes_4(sIn)
    'make a byte array of the private key
    SecretKey = asc.Getbytes_4(sSecretKey)
    'add the private key property to the encryption object
    enc.Key = SecretKey

    'make a byte array of the hash
    bytes = enc.ComputeHash_2((bytes))
    
    'convert the byte array to string
    If b64 = True Then
       StrToSHA512Salt = ConvToBase64String(bytes)
    Else
       StrToSHA512Salt = ConvToHexString(bytes)
    End If
    
    'release object variables
    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function ConvToBase64String(vIn As Variant) As Variant

    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

Private Function ConvToHexString(vIn As Variant) As Variant

    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

See Also[edit]

  • File Hashing in VBA : A companion page in this series that lists code for single file hashing. Combine this with file listing code for extensive hashing of files.
  • Folder Hashing in VBA :Another companion page that makes recursive folder hash listings, and logs. Uses up to date hash algorithms, but limited to files no larger than about 200MB.



File Hashing in VBA

Summary[edit]

  • This section contains code for making file hashes, that is, hashes of entire files.
    • Several algorithms are provided, with output options for base64 or hex. The VBA code below generates the digests for the MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes.
    • The code is made for single files, but the code given on an adjacent page, Folder Hashing in VBA, can be used for recursive hash listings, again with a choice of hashes and output options.
    • String hash routines are given in another section.
    • In general these hashes do not make use of a seed value, but to illustrate the method, the code contains one such example, (FileToSHA512SALT()). Please note that its output differs from that of the SHA512Managed class. A note exists in the respective procedure in case other salted (seeded) inputs are of interest.
    • These listed algorithms can hash any single file up to about 200MB (Mega Bytes) in length, beyond which an out of memory error will be generated in GetFileBytes(). Specific tests found that hashes work well for a 200MB zip file but fail for a 500MB zip file; the exact break point is unclear. For files larger than 200MB, other facilities exist.
  • Large file hashing, say beyond 200MB is best done with other tools. Four such examples are mentioned here:
    • Microsoft's FCIV utility, is free download. It is a command-line application, capable of hashing both single files and whole folder trees. It handles large files with ease, but only for MD5 and SHA1 hashes. It sends both base64 and HEX outputs to the screen but only b64 output format to a file. Prepared files can be verified against any new run, but results only to the screen. It is a bit tricky to use, even with their instructions, so the pages Running the FCIV Utility from VBA and File Checksum Integrity Verifier (FCIV) Examples might be found of use to the novice. So far, Microsoft have not extended the coding to include contemporary algorithms.
    • PowerShell in Windows 8.1 and above, can make large single-file hashes, using all of the MD5. SHA1, SHA256, SHA384, and SHA512 algorithms. It produces output on the screen only, though the output can also be piped to the clipboard for pasting as required. There are no simple options for hashing a folder or for output to an xml file. For completion, an example of its use is given in File Checksum Integrity Verifier (FCIV) Examples.
    • An external application that can handle large files is MD5 and SHA Checksum Utility. It is a stand-alone application, and a basic version is available as a free download. It produces MD5, SHA1, SHA2/256, and SHA2/512 hashes for single files. The outputs are in HEX and are displayed together on a neat user interface. A more complex commercial version is also available.
    • FSUM Fast File Integrity Checker is another free, external application for command line use. It resembles FCIV in many ways but includes up to date algorithms. (MD2, MD4, MD5, SHA-1, SHA-2( 256, 384, 512), RIPEMD-160, PANAMA, TIGER, ADLER32, and CRC32). In addition to large file HEX hashes it can carry out flat or recursive folder hashes. The code to enter is not identical to that of FCIV but a text file is provided with examples in its use. The web page FSUM Fast File Integrity Checker has the download and other details, though the text file fails to mention that results can be easily piped to the clipboard with |clip. Although a graphical interface exists elsewhere, the command-line application has been found the most stable..
  • The permissions for files need to be considered when attempting hashing. Hashing has to access files to obtain the bytes that they contain. Although this does not involve actually running the files, some folder and file types might be found locked at run time. In fact, this type of access is the main difference between string hashing and file hashing. Whenever files are accessed, error handling tends to be needed. It is assumed here that the user will add his own error-handling, or that he will go-around files that are troublesome before the hashing attempt. Users should know that the code cannot handle an empty text file; for example, a Notepad file that has been saved without any text in it. The GetFileBytes routine will error. A message and exit will be produced if an empty file is encountered, as for a file in excess of 200MB.
  • User files and folders have few restrictions. The empty file problem apart, those who want to access user files in folders that they have made themselves will not usually have any problems, and interested parties should know that there is a recursive folder hashing module in another section of this series that might be of related interest. Folder Hashing in VBA also contains notes on how to avoid virtual folder problems with music, video, and other Microsoft libraries.
  • Hashing is concerned only with the content of a file, and not its name, or other file details. This means that duplicates of files under any name can be found by comparing their hashes. In secure systems with deliberately confusing file names, this means that a very long file list could be hashed until a searched-for hash value is found, rather than depending on a less secure file name to find it. Alternatively, file names are sometimes just the file's hash value, so that hashing can reveal any error or illegal change. In such a case a hacker might change the file then name the file with a corresponding hash, but he does not know the required hash algorithm or private string to use, so changes will always be detected when the owner runs his own hash verification.

Code Listings[edit]

Modifications[edit]

  • Added file selection dialog, and file size limits, 17 Jun 2019
  • Set file selection dialog to open with all-file types to be listed, 25 July 2019

Using Built-in Windows Functions in VBA[edit]

The code to make hashes of STRINGS and for bulk file hashing is given elsewhere in this set. The panel below bears code that is virtually identical to that for strings, but with only slight modification, is used to make hashes of single whole FILES. The user provides a full path to the file via a selection dialog as the starting parameter. A parameter option allows for a choice of hex or base-64 outputs. Functions are included for MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512 hashes.

For frequent use, the selection dialog is most convenient, though the code contains a commented-out line for those who intend to type the file address into the procedure; simply comment out the line not needed.

In each case, coders can find the unmodified hash values in the bytes() array and at that point they are in 8-bit bytes, that is, the numbers that represent the ASCI code as it applies to a full eight-bit, 256 character set. The code that follows the filling of the bytes() array in each case decides which version of the ASCI character set to deliver. For a hex set of characters, 0-9, and A to F, the total bit set is broken into double the number of four-bit bytes, then returned for use. For the base-64 set, lower case letters,upper case letters, and integers mainly, six bit characters are made for output. These two sets are the most useful here, since they consist of commonly used characters. The 128 and 256 ASCI sets are too full of both exotic and non-printing characters to be useful. For each hash version its bit count is a constant, so the length of its output will vary according to the chosen type.

As a general point; message boxes do not allow copying of their text. If copying is needed, replace the message box with an input box, and set the output hash to be the default value of the box. Then it can be copied with ease. Alternatively use the output of the Debug.Print method in the immediate window.

Option Explicit

Private Sub TestFileHashes()
    'run this to obtain file hashes in a choice of algorithms
    'select any one algorithm call below
    'Limited to unrestricted files less than 200MB and not zero
    'Set a reference to mscorlib 4.0 64-bit, and Scripting Runtime
    
    Dim sFPath As String, b64 As Boolean, bOK As Boolean
    Dim sH As String, sSecret As String, nSize As Long, reply
    
    'USER SETTINGS
    '======================================================
    '======================================================
    'set output format here
    b64 = True     'true for output base-64, false for hex
    '======================================================
    'set chosen file here
    'either set path to target file in hard-typed line
    'or choose a file using the file dialog procedure
    'sFPath = "C:\Users\Your Folder\Documents\test.txt" 'eg.
    sFPath = SelectFile2("SELECT A FILE TO HASH...") 'uses file dialog
        
    'check the file
    If sFPath = "" Then 'exit sub for no file selection
        MsgBox "No selection made - closing"
        Exit Sub
    End If
    bOK = GetFileSize(sFPath, nSize)
    If nSize = 0 Or nSize > 200000000 Then 'exit sub for zero size
        MsgBox "File has zero contents or greater than 200MB - closing"
        Exit Sub
    End If
    '======================================================
    'set secret key here if using HMAC class of algorithms
    sSecret = "Set secret key for FileToSHA512Salt selection"
    '======================================================
    'choose algorithm
    'enable any one line to obtain that hash result
    'sH = FileToMD5(sFPath, b64)
    'sH = FileToSHA1(sFPath, b64)
    'sH = FileToSHA256(sFPath, b64)
    'sH = FileToSHA384(sFPath, b64)
    'sH = FileToSHA512Salt(sFPath, sSecret, b64)
    sH = FileToSHA512(sFPath, b64)
    '======================================================
    '======================================================
    
    'Results Output - open the immediate window as required
    Debug.Print sFPath & vbNewLine & sH & vbNewLine & Len(sH) & " characters in length"
    MsgBox sFPath & vbNewLine & sH & vbNewLine & Len(sH) & " characters in length"
    'reply = InputBox("The selected text can be copied with Ctrl-C", "Output is in the box...", sH)
    
    'decomment this block to place the hash in first cell of sheet1
'    With ThisWorkbook.Worksheets("Sheet1").Cells(1, 1)
'        .Font.Name = "Consolas"
'        .Select: Selection.NumberFormat = "@" 'make cell text
'        .Value = sH
'    End With
End Sub

Public Function FileToMD5(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an MD5 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath)
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToMD5 = ConvToBase64String(bytes)
    Else
       FileToMD5 = ConvToHexString(bytes)
    End If
        
    Set enc = Nothing

End Function

Public Function FileToSHA1(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA1 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA1 = ConvToBase64String(bytes)
    Else
       FileToSHA1 = ConvToHexString(bytes)
    End If
        
    Set enc = Nothing

End Function

Function FileToSHA512Salt(ByVal sPath As String, ByVal sSecretKey As String, _
                           Optional ByVal bB64 As Boolean = False) As String
    'Returns a sha512 FILE HASH in function name, modified by parameter sSecretKey.
    'This hash differs from that of FileToSHA512 using the SHA512Managed class.
    'HMAC class inputs are hashed twice;first input and key are mixed before hashing,
    'then the key is mixed with the result and hashed again.
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim asc As Object, enc As Object
    Dim SecretKey() As Byte
    Dim bytes() As Byte
    
    'create a text and crypto objects
    Set asc = CreateObject("System.Text.UTF8Encoding")
    
    'Any of HMACSHAMD5,HMACSHA1,HMACSHA256,HMACSHA384,or HMACSHA512 can be used
    'for corresponding hashes, albeit not matching those of Managed classes.
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA512")

    'make a byte array of the text to hash
    bytes = GetFileBytes(sPath)
    
    'make a byte array of the private key
    SecretKey = asc.Getbytes_4(sSecretKey)
    'add the key property
    enc.Key = SecretKey

    'make a byte array of the hash
    bytes = enc.ComputeHash_2((bytes))
    
    'convert the byte array to string
    If bB64 = True Then
       FileToSHA512Salt = ConvToBase64String(bytes)
    Else
       FileToSHA512Salt = ConvToHexString(bytes)
    End If
    
    'release object variables
    Set asc = Nothing
    Set enc = Nothing

End Function

Public Function FileToSHA256(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA2-256 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA256Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA256 = ConvToBase64String(bytes)
    Else
       FileToSHA256 = ConvToHexString(bytes)
    End If
        
    Set enc = Nothing

End Function

Public Function FileToSHA384(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA2-384 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA384Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA384 = ConvToBase64String(bytes)
    Else
       FileToSHA384 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing

End Function

Public Function FileToSHA512(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an SHA2-512 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes, outstr As String, pos As Integer
    
    Set enc = CreateObject("System.Security.Cryptography.SHA512Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
       FileToSHA512 = ConvToBase64String(bytes)
    Else
       FileToSHA512 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing

End Function

Private Function GetFileBytes(ByVal sPath As String) As Byte()
    'makes byte array from file
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim lngFileNum As Long, bytRtnVal() As Byte, bTest
    
    lngFileNum = FreeFile
    
    If LenB(Dir(sPath)) Then ''// Does file exist?
        
        Open sPath For Binary Access Read As lngFileNum
        
        'a zero length file content will give error 9 here
        
        ReDim bytRtnVal(0 To LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53 'File not found
    End If
    
    GetFileBytes = bytRtnVal
    
    Erase bytRtnVal

End Function

Function ConvToBase64String(vIn As Variant) As Variant
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

Function ConvToHexString(vIn As Variant) As Variant
     'used to produce a hex output
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim oD As Object
      
    Set oD = CreateObject("MSXML2.DOMDocument")
      
      With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
      End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing

End Function

Function GetFileSize(sFilePath As String, nSize As Long) As Boolean
    'use this to test for a zero file size
    'takes full path as string in sFilePath
    'returns file size in bytes in nSize
    'Make a reference to Scripting Runtime
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sFilePath) Then
        Set f = fs.GetFile(sFilePath)
        nSize = f.Size
        GetFileSize = True
        Exit Function
    End If

End Function

Function SelectFile2(Optional sTitle As String = "") As String
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    
    Dim fd As FileDialog, sPathOnOpen As String, sOut As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    'do not include backslash here
    sPathOnOpen = Application.DefaultFilePath
    
    'set the file-types list on the dialog and other properties
    With fd
        .Filters.Clear
        'the first filter line below sets the default on open (here all files are listed)
        .Filters.Add "All Files", "*.*"
        .Filters.Add "Excel workbooks", "*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
        .Filters.Add "Word documents", "*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
                
        .AllowMultiSelect = False
        .InitialFileName = sPathOnOpen
        .Title = sTitle
        .InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
        .Show
        
        If .SelectedItems.Count = 0 Then
            'MsgBox "Canceled without selection"
            Exit Function
        Else
            sOut = .SelectedItems(1)
            'MsgBox sOut
        End If
    End With
    
    SelectFile2 = sOut

End Function

See Also[edit]

  • String Hashing in VBA : A companion page in this series for those who want only to hash strings.
  • Folder Hashing in VBA :Another companion page that makes recursive folder hash listings, and logs. Uses up to date hash algorithms, but limited to files no larger than about 200MB.
  • Running the FCIV Utility from VBA: How to use the Microsoft fciv.exe command line utility to make MD5 and SHA1 file hashes from VBA. The MS utility, although awkward to use, allows hashing and verification of entire folder trees.
  • File Checksum Integrity Verifier (FCIV) Examples: More details on how to use the FCIV utility for those without much experience working from the command line prompt.

External Links[edit]

  • MD5 and SHA Checksum Utility: a external site's free application to simultaneously display MD5,SHA1,SHA256,and SHA512 hashes of single files (Hex only). Includes a browse-for-file function and drag and drop to make life easy. This utility can also be used to hash large files; author-tested for a 500MB file.
  • FSUM Fast File Integrity Checker : The basic command-line version of the FSUM hasher download.
  • FSUM GUI : A graphical interface download site for the FSUM utility. This allows file browsing, drag and drop, and other facilities to simplify the otherwise command-line working.



Folder Hashing in VBA

Summary[edit]

Figure 1: The user form for the project. The names of controls correspond to those used in the code modules. The frames that contain OptionButtons must exist, but the frame names are arbitrary. Click the image for an enlarged view.
  • These modules are made for Microsoft Excel only. It hashes files in whole folders. It handles both flat and recursive folder listing, makes log files, and verifies files against hash files made previously.
  • Any of five hash algorithms can be used on the worksheet. They are, MD5, SHA1, SHA256, SHA384, and SHA512,. They are displayed on Sheet1 of the workbook in either hex or base64 formats. If log files are also required for these hashes, they are made in SHA512-b64 format for future verification; this format is independent of the format chosen for worksheet listings.
  • Verification results appear on Sheet2 of the workbook. Verification failures are highlighted in red. Make sure therefore that Sheet1 and Sheet2 exist in the workbook. These results can also be delivered to a log file for future use.
  • Log files, when made, are found in the default folder. Make log choices on the user form's check box options.
    • HashFile*.txt logs have a name that is date-stamped, and contains the number of files listed in it. Separate logs can be made for each run.
    • HashErr.txt is the error log. It logs file item paths that could not be hashed. There is only one of these, and the results for each run are appended with a date-time stamp. When full, just delete it and a new one will be made as required.
    • VerReport*.txt logs a copy of verification results. A separate log can be made for each verification run. It too has a date-time stamp in its file name.
  • The process is slower than FCIV, but has more algorithms to choose from. However, unlike FCIV no single file can exceed about 200MB. See File Hashing in VBA for notes on ways to hash larger files. A recursive run of the Documents folder, (2091 user files, and 1.13GB in total), took seven and a half minutes. It included writing to the worksheet, making a hash log, and logging 36 filter exclusions in an error file. Verification is faster, taking about half of that time.
  • A user form layout is shown in Figure 1. The exact control names are given, and these correspond exactly to those in code. The use of the same control names is essential for a trouble-free installation. Regrettably, there is no way in Wikibooks to download an Excel file, or for that matter the VBA code files themselves, so the main work is in the making of the user form.
  • Set filter conditions in FilterOK(). The fastest results can be had when the filter conditions are as narrow as possible. A wide range of filter conditions can be set directly in code, and for items filtered, their paths will be listed in the error file.
  • Be sure to set VBA Project references. Required are Visual Basic for Applications Extensibility 5.3, mscorlib.dll, and Microsoft Scripting Runtime, in addition to any others that you may require. The VBA editor's error setting should be Break on Unhandled Errors.
  • My Documents versus Documents. There are four virtual folders in the Libraries category of the Windows Explorer, My Documents, My Music, My Pictures, and My Videos. When the Windows Explorer's Folder Options are set to NOT display hidden files, folders, drives and Operating system files, the correct locations are nonetheless returned by the folder selection dialogs, namely Documents, Music, Pictures, and Videos. When there are NO restrictions on viewing hidden and operating system files and folders, then selection dialogs will wrongly attempt to return these virtual paths, and access violations will result. It is only by avoiding this situation that easy listings can be obtained, so check that the Folder Options of Windows Explorer are set in accordance with Figure 2.

The Code Modules[edit]

Figure 2: Denied access to files can be avoided in part by ensuring that operating system files are not shown. The use of these settings will avoid many problems.

There are three modules to consider; the ThisWorkbook module, that contains the code to run automatically at startup; the Userform1 module, that contains the code for the controls themselves, and the main Module1 code that contains everything else.

  • Make sure that Sheet1 and Sheet2 exist on the workbook.
  • Then, make a user form called UserForm1, carefully using the same names as the controls in Figure 1, and in exactly the same places. Set the UserForm1 as non-modal in its properties. Save the Excel file with an *.xlsm suffix.
  • Double click the UserForm1, (not a control), in design mode, to open the code module associated with it, then copy the respective code block into it. Save the Excel file. (Saving the file in the VBE editor is exactly the same as saving on the workbook.)
  • Insert a standard module, and copy the main code listing into it. Save the file.
  • Lastly, when all other work is done, transfer the ThisWorkbook code, and save the file.
  • Set the Windows Explorer folder options in accordance with Figure 2.
  • Close the Excel workbook, then reopen it to be display the user form. If the user form is closed for any reason, it can be re-opened by running the Private Sub Workbook_Open() procedure in the ThisWorkbook module. (ie: Place cursor in the procedure then press F5.)

Using the App[edit]

There are two main functions; making hashes on the worksheet and an optional hash log, and verifying computer folders against a previously made hash log. The hashing mode also includes an optional error log, to list both errors and files avoided by the user-set filters. Verification results use an optional log of their own. Be sure to note the required Folder Options of Figure 2 before any hashing activities.

Making hashes[edit]

  • Set the options, recursion, output format, and hash algorithm in the topmost panel. Make log file selections on the check boxes.
  • Select a folder to hash with Select Folder to Hash. Then, pressing the Hash Folder button starts the listing on Sheet1 of the workbook.
  • Wait for the run to finish. The user form's top-caption changes to advise that the application is still processing, and message boxes advise when the run is complete. The Stop all Code button can be pressed at any time to return to the VBA editor in either of the two working modes.
  • Filtered files will be ignored in hashing. These are files deliberately avoided by user settings in the FilterOK() procedure. Such files will be listed in the error file (HashErr*.txt), if selected.
  • Log files are available for inspection, if such options were selected, located most often in the workbook's launch folder.
  • Restrict hashing to user libraries. Owing to the large numbers of hidden and otherwise restricted files in Windows, it is recommended that hashing be restricted to the contents of the user profiles. Although some files will be restricted even there, for most this is not much of a limitation, since it still includes Documents, Downloads, Music, Pictures, and Videos, and various other folders.

Verifying Folders[edit]

The verification process verifies only those file paths that are listed on the chosen hash file, and will not even consider files added to the file folders since the hash file was made. When folders are changed, new hash files need to be made in a working system.

  • Make a file selection in the bottom panel, by pressing Select File to Verify. This must be a log file (HashFile*.txt) made at an earlier time for the purpose of verification. It is the same file that can be made during a hash run, and regardless of any settings made for worksheet listing, these files will always be made as SHA512-b64 format.
  • Press Start Verification to start the process. Results are listed on Sheet2 of the worksheet, and any failures are color-highlighted. The user form caption changes to advise that the application is still processing, and message boxes advise when the process is complete.
  • Review the results , either on Sheet2 or in the verification results file (VerHash*.txt) in the default folder. Consider further action.

Code Modification Notes[edit]

  • Code modified 28 Jan 19, modified SelectFile(), to set All Files as default display.
  • Code modified 9 Dec 18, corrected CommandButton6_Click(), one entry wrongly marked sSht instead of oSht.
  • Code modified 5 Dec 18, corrected Module1, code error in initializing public variables.
  • Code modified 5 Dec 18, updated Module1 and UserForm1 for improved status bar reporting and sheet1 col E heading.
  • Code modified 4 Dec 18, updated Module1 and UserForm1 for more responsive output and reporting improvements.
  • Code modified 2 Dec 18, updated Module1 for error reporting improvements, and GetFileSize() larger file reporting.
  • Code modified 1 Dec 18, corrected Module1 and UserForm1 for error log issues.
  • Code modified 30 Nov 18, updated to provide algorithm selection and a new userform layout.
  • Code modified 23 Nov 18, corrected sheet number error, format all code, and remove redundant variables.
  • Code modified 23 Nov 18 updated to add verification and a new userform layout.
  • Code modified 21 Nov 18 updated to add error logging and hash logging.

ThisWorkbook Module[edit]

Private Sub Workbook_Open()
   'displays userform for
   'options and running
   
   Load UserForm1
   UserForm1.Show

End Sub

The Userform1 Module[edit]

Option Explicit
Option Compare Binary 'default,important

Private Sub CommandButton1_Click()
    'opens and returns a FOLDER path
    'using the BrowseFolder() dialog
    'Used to access the top folder for hashing
    
    'select folder
    sTargetPath = BrowseFolder("Select a folder to list...", 0)
    
    'test for cancel or closed without selection
    If sTargetPath <> "" Then
        Label2.Caption = sTargetPath 'update label with path
    Else
        Label2.Caption = "No folder selected"
        sTargetPath = ""  'public
        Exit Sub
    End If
'option compare
End Sub

Private Sub CommandButton2_Click()
    'Pauses the running code
    'Works best in combination with DoEvents
    
    MsgBox "To fully reset the code, the user should first close this message box," & vbCrLf & _
    "then select RESET on the RUN drop-menu item of the VBE editor..." & vbCrLf & _
    "If not reset, it can be started again where it paused with CONTINUE.", , "The VBA code has paused temporarily..."
    Stop
    
End Sub

Private Sub CommandButton3_Click()
    'starts the hashing run in
    'HashFolder() via RunFileListing()
    
    Dim bIsRecursive As Boolean
        
    'flat folder or recursive options
    If OptionButton2 = True Then
        bIsRecursive = True
    Else
        bIsRecursive = False
    End If
    
    'test that a folder has been selected before listing
    If Label2.Caption = "No folder selected" Or Label2.Caption = "" Then
        'no path was established
        MsgBox "First select a folder for the listing."
        Me.Caption = "Folder Hasher...Ready..."
        'Me.Repaint
        Exit Sub
    Else
        'label
        Me.Caption = "Folder Hasher...Processing...please wait."
        'make the file and hash listing
        RunFileListing sTargetPath, bIsRecursive
        Me.Caption = "Folder Hasher...Ready..."
        'Me.Repaint
    End If
    
End Sub

Private Sub CommandButton5_Click()
    'opens and returns a file path
    'using the SelectFile dialog.
    'Used to access a stored hash file
    'for a Verification run
    
    sVerifyFilePath = SelectFile("Select the file to use for Verification...")
    
    If sVerifyFilePath <> "" Then
        Label3.Caption = sVerifyFilePath
    Else
        'MsgBox "Cancelled listing"
        Label3.Caption = "No file selected"
        sVerifyFilePath = ""  'public
        Exit Sub
    End If
    
End Sub

Private Sub CommandButton6_Click()
    'runs the verification process
    'compares stored hashes with hashes made now
    'Compares case sensitive. Internal HEX is lower case a-f and integers.
    'Internal Base64 is upper letters, lower letters and integers.
        
    Dim bOK As Boolean, sAllFileText As String, vL As Variant
    Dim nLine As Long, vF As Variant, sHashPath As String, bNoPath As Boolean
    Dim sOldHash As String, sNewHash64 As String, StartTime As Single
    Dim sVerReport As String, oSht As Worksheet
    
    'format of hash files is as follows
    'path,sha512 ... ie; two fields, comma separated
    'one record per line, each line ending in a line break (vbcrlf)
    
    'fetch string from file
    If Label3.Caption = "No file selected" Or Label3.Caption = "" Then
        MsgBox "First select a file for verification"
        Exit Sub
    ElseIf GetFileSize(sVerifyFilePath) = 0 Then
        MsgBox "File contains no records"
        Exit Sub
    Else:
        bOK = GetAllFileText(sVerifyFilePath, sAllFileText)
    End If
    
    'get the system timer value
    StartTime = Timer
    
    Me.Caption = "Folder Hasher...Processing...please wait."
    
    'prepare the worksheet
    Set oSht = ThisWorkbook.Worksheets("Sheet2")
    ClearSheetContents "Sheet2"
    ClearSheetFormats "Sheet2"
    
    'split into lines -split is zero based
    vL = Split(sAllFileText, vbNewLine)
    
    'then for each line
    For nLine = LBound(vL) To UBound(vL) - 1
        DoEvents 'submit to system command stack
        'now split each line into fields on commas
        vF = Split(vL(nLine), ",")
        'obtain the path to hash from first field
        sHashPath = vF(0) 'split is zero based
        sOldHash = vF(1) 'read from file field
        
        'Check whether or not the path on the hash file exists
        bNoPath = False
        If FilePathExists(sHashPath) Then
            sNewHash64 = FileToSHA512(sHashPath, True) 'sha512-b64
        Else
            'record fact on verification report
            bNoPath = True
        End If
        
        oSht.Activate
        oSht.Cells(nLine + 2, 2) = sHashPath  'file path col 2
        If bNoPath = False Then 'the entry is for a valid path
            'if sOldHash is same as sNewHash64 then the file is verified - else not
            'prepare a verification string for filing and output line by line to worksheet
            'Debug.Print sOldHash
            'Debug.Print sNewHash64
            If sOldHash = sNewHash64 Then
                sVerReport = sVerReport & "VERIFIED OK , " & sHashPath & vbCrLf
                'export to the worksheet
                oSht.Cells(nLine + 2, 1) = "VERIFIED OK"
            Else:
                sVerReport = sVerReport & "FAILED MATCH, " & sHashPath & vbCrLf
                oSht.Cells(nLine + 2, 1) = "FAILED MATCH"
                oSht.rows(nLine + 2).Cells.Interior.Pattern = xlNone
                oSht.Cells(nLine + 2, 1).Interior.Color = RGB(227, 80, 57) 'orange-red
                oSht.Cells(nLine + 2, 2).Interior.Color = RGB(227, 80, 57) 'orange-red
            End If
        Else     'the entry is for an invalid path ie; since moved.
            sVerReport = sVerReport & "PATH NOT FOUND, " & sHashPath & vbCrLf
            oSht.Cells(nLine + 2, 1) = "PATH NOT FOUND"
            oSht.rows(nLine + 2).Cells.Interior.Pattern = xlNone
            oSht.Cells(nLine + 2, 1).Interior.Color = RGB(227, 80, 57) 'orange-red
            oSht.Cells(nLine + 2, 2).Interior.Color = RGB(227, 80, 57) 'orange-red
        End If
        
    Next nLine
    
    FormatColumnsAToB ("Sheet2")
    
    'export the report to a file
    bOK = False
    If CheckBox3 = True Then
        bOK = MakeHashLog(sVerReport, "VerReport")
    End If
    
    Me.Caption = "Folder Hasher...Ready..."
    
    'get the system timer value
    EndTime = Timer
    
    If bOK Then
        MsgBox "Verification results are on Sheet2" & vbCrLf & "and a verification log was made." & vbCrLf & _
        "The verification took " & Round((EndTime - StartTime), 2) & " seconds"
    Else
        MsgBox "Verification results are on Sheet2" & vbCrLf & _
        "The verification took " & Round((EndTime - StartTime), 2) & " seconds"
    End If
    
    Set oSht = Nothing

End Sub

Private Sub UserForm_Initialize()
    'initializes Userform1 variables
    'between form load and form show
    
    Me.Caption = "Folder Hasher...Ready..."
    OptionButton2 = True 'recursive listing default
    OptionButton3 = True 'hex output default
    OptionButton9 = True 'sha512 worksheet default
    Label2.Caption = "No folder selected"
    Label3.Caption = "No file selected"
    CheckBox1 = False 'no log
    CheckBox2 = False 'no log
    CheckBox3 = False 'no log
End Sub

The Standard Module1[edit]

Option Explicit
Option Base 1
Option Private Module
Option Compare Text 'important

Public sht1 As Worksheet          'hash results
Public StartTime As Single        'timer start
Public EndTime As Single          'timer end
Public sTargetPath As String      'selected hash folder
Public sVerifyFilePath As String  'selected verify file
Public sErrors As String          'accum output error string
Public sRecord As String          'accum output hash string
Public nErrors As Long            'accum number hash errors
Public nFilesHashed As Long       'accum number hashed files

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modBrowseFolder
' These declarations are for the BrowseFolder() function, which displays the standard Windows Browse For Folder
' dialog. It returns the complete path of the selected folder or vbNullString if the user cancelled.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszINSTRUCTIONS As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, _
ByVal pszBuffer As String) As Long

Private Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As _
BROWSEINFO) As Long

Private Const MAX_PATH = 260 ' Windows mandated


Function BrowseFolder(Optional ByVal DialogTitle As String, _
    Optional RootCSIDL As Long = 0) As String
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' BrowseFolder
    ' This displays the standard Windows Browse Folder dialog. It returns
    ' the complete path name of the selected folder or vbNullString if the
    ' user cancelled. Depends on declarations at module heading
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Useful RootCSIDL values
    ' The zero default opens with a good balance of drives and folders
    ' &H5 opens with My Documents at top and nothing above.
    ' &H11 opens with the drives at the top ready to expand
    ' IMPORTANT
    ' Virtual folders, eg; "My Documents", "My MUsic", return "Documents"
    ' and "Music" provided that Windows Folder Options DO NOT SHOW HIDDEN FOLDERS
    ' and HIDE OPERATING SYSTEM FILES.  Otherwise the virtual folders
    ' themselves will be returned, with assured listing errors.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    Dim uBrowseInfo As BROWSEINFO
    Dim szBuffer As String
    Dim lID As Long
    Dim lRet As Long
    
    If DialogTitle = vbNullString Then
        DialogTitle = "Select A Folder"
    End If
    
    With uBrowseInfo
        .hOwner = 0
        .pidlRoot = RootCSIDL
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = DialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS ' + BIF_USENEWUI
        .lpfn = 0
    End With
    szBuffer = String$(MAX_PATH, vbNullChar)
    lID = SHBrowseForFolderA(uBrowseInfo)
    
    If lID Then
        ''' Retrieve the path string.
        lRet = SHGetPathFromIDListA(lID, szBuffer)
        If lRet Then
            BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
        End If
    End If
    
End Function

Sub RunFileListing(sFolder As String, Optional ByVal bRecursive As Boolean = True)
    'Runs HashFolder() after worksheet prep
    'then handles output messages to user
    
    'initialize file-counting and error counting variables
    nFilesHashed = 0   'public
    nErrors = 0        'public
    sErrors = ""       'public
    sRecord = ""       'public
    StartTime = Timer  'public
    nFilesHashed = 0   'public
    
    'initialise and clear sheet1
    Set sht1 = ThisWorkbook.Worksheets("Sheet1")
    sht1.Activate
    ClearSheetContents "Sheet1"
    ClearSheetFormats "Sheet1"
    'insert sheet1 headings
    With sht1
        .Range("a1").Formula = "File Path:"
        .Range("b1").Formula = "File Size:"
        .Range("c1").Formula = "Date Created:"
        .Range("d1").Formula = "Date Last Modified:"
        .Range("e1").Formula = Algorithm 'function
        .Range("A1:E1").Font.Bold = True
        .Range("A2:E20000").Font.Bold = False
        .Range("A2:E20000").Font.Name = "Consolas"
    End With
    
    'Run the main listing procedure
    'This outputs to sheet1
    HashFolder sFolder, bRecursive
    
    'autofit sheet1 columns A to E
    With sht1
        .Range("A1").Select
        .Columns("A:E").AutoFit
        .Range("A1").Select
        .Cells.FormatConditions.Delete 'reset any conditional formatting
    End With
    
    'get the end time for the hash run
    EndTime = Timer
    
    'MAKE LOGS AS REQUIRED AND ISSUE COMPLETION MESSAGES
    Select Case nFilesHashed 'the public file counter
    Case Is <= 0 'no files hashed but still consider need for error log
        'no files hashed, errors found, error log requested
        If nErrors <> 0 And UserForm1.CheckBox2 = True Then
            '------------------------------------------------------------
            MakeErrorLog sErrors  'make an error log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & nErrors & " errors noted and logged."
            'no files hashed, errors found, error log not requested
        ElseIf nErrors <> 0 And UserForm1.CheckBox2 = False Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & nErrors & " errors noted but unlogged."
            'no files hashed, no errors found, no error log made regardless requested
        ElseIf nErrors = 0 Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No hashes made." & vbCrLf & "Error free."
        End If
    Case Is > 0 'files were hashed
        'files were hashed, hash log requested
        If UserForm1.CheckBox1 = True Then
            '------------------------------------------------------------
            MakeHashLog sRecord, "HashFile"  'make a hash log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "A log file of these hashes was made."
            'files were hashed, no hash log requested
        Else
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox "No log file of these hashes was made."
        End If
        'make error files as required
        'files were hashed, errors found, error log requested
        If nErrors <> 0 And UserForm1.CheckBox2 = True Then
            '------------------------------------------------------------
            MakeErrorLog sErrors  'make an error log
            '------------------------------------------------------------
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & nErrors & " errors noted and logged."
            'files were hashed, errors found, error log not requested
        ElseIf nErrors <> 0 And UserForm1.CheckBox2 = False Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & nErrors & " errors noted but unlogged."
            'files were hashed, no errors found, no error log made regardless requested
        ElseIf nErrors = 0 Then
            UserForm1.Caption = "Folder Hasher...Ready..."
            MsgBox nFilesHashed & " hashes to Sheet1." & vbCrLf & " Error free."
        End If
    End Select
    
    'reset file counting and error counting variables
    nFilesHashed = 0   'public
    nErrors = 0
    
    'caption for completion
    UserForm1.Caption = "Folder Hasher...Ready..."
    
    'time for the hash run itself
    MsgBox "Hashes took " & Round(EndTime - StartTime, 2) & " seconds."
    
    'reset status bar
    Application.StatusBar = ""
    
    Set sht1 = Nothing

End Sub

Sub HashFolder(ByVal SourceFolderName As String, IncludeSubfolders As Boolean)
    'Called by RunFileListing() to prepare hash strings blocks for output.
    'IncludeSubfolders true for recursive listing; else flat listing of first folder only
    'b64 true for base64 output format, else hex output
    'Choice of five hash algorthms set on userform options
    'Hash log always uses sha512-b64, regardless of sheet1 algorithm selections
    'File types, inclusions and exclusions are set in FilterOK()
    
    Dim FSO As Object, SourceFolder As Object, sSuff As String, vS As Variant
    Dim SubFolder As Object, FileItem As Object, sPath As String, sReason As String
    Dim m As Long, sTemp As String, nErr As Long, nNextRow As Long
        
    'm counts accumulated file items hashed - it starts each proc run as zero.
    'nFilesHashed (public) stores accumulated value of m to that point, at the end
    'of each iteration. nErr accumulates items not hashed as errors, with nErrors
    'as its public storage variable.
    
    'transfer accumulated hash count to m on every iteration
    m = m + nFilesHashed 'file count
    nErr = nErr + nErrors 'error count
        
    On Error GoTo Errorhandler
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    
    For Each FileItem In SourceFolder.Files
        DoEvents 'permits running of system commands- ie interruption
        sTemp = CStr(FileItem.Name)
        sPath = CStr(FileItem.path)
        vS = Split(CStr(FileItem.Name), "."): sSuff = vS(UBound(vS))
        
        'Raise errors for testing handler and error log here
        'If sTemp = "test.txt" Then Err.Raise 53   'Stop
        
        'running hash count and running error count to status bar
        Application.StatusBar = "Processing...Files Hashed: " & _
                                 m & " : Not Hashed: " & nErr
        
        'Decide which files are listed FilterOK()
        If FilterOK(sTemp, sPath, sReason) And Not FileItem Is Nothing Then
            m = m + 1 'increment file count within current folder
                    
            'get next sht1 row number - row one already filled with labels
            nNextRow = sht1.Range("A" & rows.Count).End(xlUp).Row + 1
            
            'send current file data and hash to worksheet
            sht1.Cells(nNextRow, 1) = CStr(FileItem.path)
            sht1.Cells(nNextRow, 2) = CLng(FileItem.Size)
            sht1.Cells(nNextRow, 3) = CDate(FileItem.DateCreated)
            sht1.Cells(nNextRow, 4) = CDate(FileItem.DateLastModified)
            sht1.Cells(nNextRow, 5) = HashString(sPath)
            
            'accumulate in string for later hash log
            'This is always sha512-b64 for consistency
            sRecord = sRecord & CStr(FileItem.path) & _
            "," & FileToSHA512(sPath, True) & vbCrLf
        
        'accumulate in string for later error log
        'for items excluded by filters
        Else
            sErrors = sErrors & FileItem.path & vbCrLf & _
            "USER FILTER: " & sReason & vbCrLf & vbCrLf
            nErr = nErr + 1   'increment error counter
        End If
    Next FileItem
    
    'increment public counter with total sourcefolder count
    nFilesHashed = m 'public nFilesHashed stores between iterations
    nErrors = nErr 'public nErrors stores between iterations
    
    'this section performs the recursion of the main procedure
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            HashFolder SubFolder.path, True
        Next SubFolder
    End If
    
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    Exit Sub
    
Errorhandler:
    If Err.Number <> 0 Then
        'de-comment message box lines for more general debugging
        
        'MsgBox "When m = " & m & " in FilesToArray" & vbCrLf & _
        "Error Number :  " & Err.Number & vbCrLf & _
        "Error Description :  " & Err.Description
        
        'accumulate in string for later error log
        'for unhandled errors during resumed working
        If sPath <> "" Then   'identify path for error log
            sErrors = sErrors & sPath & vbCrLf & Err.Description & _
            " (ERR " & Err.Number & " )" & vbCrLf & vbCrLf
        Else    'note that no path is available
            sErrors = sErrors & "NO PATH COULD BE SET" & vbCrLf & _
            Err.Description & " (ERR " & Err.Number & " )" & vbCrLf & vbCrLf
        End If
        
        nErr = nErr + 1       'increment error counter
        Err.Clear             'clear the error
        Resume Next           'resume listing but errors are logged
    End If
    
End Sub

Function FilterOK(sfilename As String, sFullPath As String, sCause As String) As Boolean
    'Returns true if the file passes all tests, else false:  Early exit on test failure.
    
    'CURRENT FILTER TESTS - Keep up to date and change these in SET USER OPTIONS below.
    'Must be included in a list of permitted file types. Can be set to "all" files.
    'File type must not be specifically excluded, for example *.bak.
    'File prefix must not be specifically excluded, for example ~ for some backup files.
    'Path must not include a specified safety string in any location, eg. "MEXSIKOE", "SAFE"
    'Must not have a hidden or system file attribute set.
    'Must not have file size zero bytes (empty text file), or greater than 200 M Bytes.
    
    Dim c As Long, vP As Variant, sPrefTypes As String, bBadAttrib As Boolean
    Dim sAll As String, bExcluded As Boolean, bKeyword As Boolean, bHiddSys As Boolean
    Dim bPrefix As Boolean, bIncluded As Boolean, vPre As Variant, bSizeLimits As Boolean
    Dim sProtected As String, vK As Variant, bTest As Boolean, vInc As Variant
    Dim sExcel As String, sWord As String, sText As String, sPDF As String, sEmail As String
    Dim sVBA As String, sImage As String, sAllUser As String, vExc As Variant, nBites As Double
    Dim sFSuff As String, sIncTypes As String, sExcTypes As String, sPPoint As String
    
    'Input Conditioning
    If sfilename = "" Or sFullPath = "" Then
        'MsgBox "File name or path missing in FilterOK - closing."
        Exit Function
    Else
    End If
    
    'ASSIGNMENTS
    'SOME SUFFIX GROUP FILTER DEFINITIONS
    
    'Excel File List
    sExcel = "xl,xlsx,xlsm,xlsb,xlam,xltx,xltm,xls,xlt,xlm,xlw"
    
    'Word File List
    sWord = "docx,docm,dotx,dotm,doc,dot"
    
    'Powerpoint file list
    sPPoint = "ppt,pot,pps,pptx,pptm,potx,potm,ppam,ppsx,ppsm,sldx,sldm"
    
    'Email common list
    sEmail = "eml,msg,mbox,email,nws,mbs"
    
    'Text File List
    sText = "adr,rtf,docx,odt,txt,css,htm,html,xml,log,err"
    
    'PDF File List
    sPDF = "pdf"
    
    'VBA Code Files
    sVBA = "bas,cls,frm,frx"
    
    'Image File List
    sImage = "png,jpg,jpeg,gif,dib,bmp,jpe,jfif,ico,tif,tiff"
    
    'All User Files Added:
    'the list of all files that could be considered...
    
    'a longer list of common user files - add to it or subtract as required
    sAllUser = "xl,xlsx,xlsm,xlsb,xlam,xltx,xltm,xls,xlt,xlm,xlw," & _
    "docx,docm,dotx,dotm,doc,dot,adr,rtf,docx,odt,txt,css," & _
    "ppt,pot,pps,pptx,pptm,potx,potm,ppam,ppsx,ppsm,sldx,sldm," & _
    "htm,html,xml,log,err,pdf,bas,cls,frm,frx,png,jpg," & _
    "jpeg,gif,dib,bmp,jpe,jfif,ico,tif,tiff,zip,exe,log"
    
    sAll = ""  'using this will attempt listing EVERY file if no other restrictions
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    'SET USER FILTER OPTIONS HERE - comma separated items in a string
    'or concatenate existing sets with a further comma string between them.
    'For example:   sIncTypes = ""                        'all types
    'sIncTypes = "log,txt"                 'just these two
    'sIncTypes = sExcel & "," & "log,txt"  'these two and excel
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'RESTRICT FILE TYPES WITH sIncTypes assignment
    'Eg sIncTypes = sWord & "," & sExcel  or for no restriction
    'use sAll or an empty string.
    
    sIncTypes = sAll 'choose other strings for fastest working
    
    'FURTHER SPECIFICALLY EXCLUDE THESE FILE TYPES
    'these are removed from the sIncTypes set, eg: "bas,frx,cls,frm"
    'empty string for none specified
    
    sExcTypes = ""       'empty string for no specific restriction
    
    'SPECIFICALLY EXCLUDE FILES WITH THIS PREFIX
    'eg "~", the tilde etc.
    'empty string means none specified
    
    sPrefTypes = "~"      'empty string for no specific restriction
    
    'SPECIFICALLY EXCLUDE FILE PATHS THAT CONTAIN ANY OF THESE SAFE STRINGS
    'add to the list as required
    
    sProtected = "SAFE,KEEP"   'such files are not listed
    
    'SPECIFICALLY EXCLUDE SYSTEM AND HIDDEN FILES
    'Set bHiddSys to true to exclude these files, else false
    
    bHiddSys = True  'exclude files with these attributes set
    
    'DEFAULT ENTRY- AVOIDS EMPTY FILES
    'Set bNoEmpties to true unless testing
    
    bSizeLimits = True
    
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    'END OF USER FILTER OPTIONS
    'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    
    'Working
    FilterOK = False
    bExcluded = False
    bIncluded = False
    bPrefix = False
    bKeyword = False
    
    'get the target file name suffix
    vP = Split(sfilename, ".")
    sFSuff = LCase(vP(UBound(vP))) 'work lower case comparison
    
NotBigSmall:
    'specifically exclude any empty files
    'that is, with zero bytes content
    If bSizeLimits = True Then 'check for empty files
        nBites = GetFileSize(sFullPath) 'nBites must be double
        
        If nBites = 0 Or nBites > 200000000 Then 'found one
            Select Case nBites
            Case 0
                sCause = "Zero Bytes"
            Case Is > 200000000
                sCause = "> 200MBytes"
            End Select
            FilterOK = False
            Exit Function
        End If
    End If
    
ExcludedSuffix:
    'make an array of EXCLUDED suffices
    'exit with bExcluded true if any match the target
    'or false if sExcTypes contains the empty string
    If sExcTypes = "" Then 'none excluded
        bExcluded = False
    Else
        vExc = Split(sExcTypes, ",")
        For c = LBound(vExc) To UBound(vExc)
            If sFSuff = LCase(vExc(c)) And vExc(c) <> "" Then
                bExcluded = True
                sCause = "Excluded Type"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
ExcludedAttrib:
    'find whether file is 'hidden' or 'system' marked
    If bHiddSys = True Then 'user excludes these
        bBadAttrib = HiddenOrSystem(sFullPath)
        If bBadAttrib Then
            sCause = "Hidden or System File"
            FilterOK = False
            Exit Function
        End If
    Else   'user does not exclude these
        bBadAttrib = False
    End If
    
Included:
    'make an array of INCLUDED suffices
    'exit with bIncluded true if any match the target
    'or if sIncTypes contains the empty string
    If sIncTypes = "" Then 'all are included
        bIncluded = True
    Else
        vInc = Split(sIncTypes, ",")
        For c = LBound(vInc) To UBound(vInc)
            If sFSuff = LCase(vInc(c)) And vInc(c) <> "" Then
                bIncluded = True
            End If
        Next c
        If bIncluded = False Then 'no match in whole list
            sCause = "Not in Main Set"
            FilterOK = False
            Exit Function
        End If
    End If
    
Prefices:
    'make an array of illegal PREFICES
    'exit with bPrefix true if any match the target
    'or false if sPrefTypes contains the empty string
    If sPrefTypes = "" Then 'none are excluded
        bPrefix = False 'no offending item found
    Else
        vPre = Split(sPrefTypes, ",")
        For c = LBound(vPre) To UBound(vPre)
            If Left(sfilename, 1) = LCase(vPre(c)) And vPre(c) <> "" Then
                bPrefix = True
                sCause = "Excluded Prefix"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
Keywords:
    'make an array of keywords
    'exit with bKeyword true if one is found in path
    'or false if sProtected contains the empty string
    If sProtected = "" Then 'then there are no safety words
        bKeyword = False
    Else
        vK = Split(sProtected, ",")
        For c = LBound(vK) To UBound(vK)
            bTest = sFullPath Like "*" & vK(c) & "*"
            If bTest = True Then
                bKeyword = True
                sCause = "Keyword Exclusion"
                FilterOK = False
                Exit Function
            End If
        Next c
    End If
    
    'Included catchall here pending testing completion
    If bIncluded = True And bExcluded = False And _
        bKeyword = False And bPrefix = False And _
        bBadAttrib = False Then
        FilterOK = True
    Else
        FilterOK = False
        sCause = "Unspecified"
    End If
    
End Function

Function HiddenOrSystem(sFilePath As String) As Boolean
    'Returns true if file has hidden or system attribute set,
    'else false. Called in FilterOK().
    
    Dim bReadOnly As Boolean, bHidden As Boolean, bSystem As Boolean
    Dim bVolume As Boolean, bDirectory As Boolean, a As Long
    
    'check parameter present
    If sFilePath = "" Then
        MsgBox "Empty parameter string in HiddenOrSystem - closing"
        Exit Function
    Else
    End If
    
    'check attributes for hidden or system files
    a = GetAttr(sFilePath)
    If a > 32 Then 'some attributes are set
        'so check the detailed attribute status
        bReadOnly = GetAttr(sFilePath) And 1   'read-only files in addition to files with no attributes.
        bHidden = GetAttr(sFilePath) And 2     'hidden files in addition to files with no attributes.
        bSystem = GetAttr(sFilePath) And 4     'system files in addition to files with no attributes.
        bVolume = GetAttr(sFilePath) And 8     'volume label; if any other attribute is specified, vbVolume is ignored.
        bDirectory = GetAttr(sFilePath) And 16 'directories or folders in addition to files with no attributes.
        
        'check specifically for hidden or system files - read only can be tested in the same way
        If bHidden Or bSystem Then
            'MsgBox "Has a system or hidden marking"
            HiddenOrSystem = True
            Exit Function
        Else
            'MsgBox "Has attributes but not hidden or system"
        End If
    Else
        'MsgBox "Has no attributes set"
    End If
    
End Function

Public Function FileToMD5(sFullPath As String, Optional bB64 As Boolean = False) As String
    'parameter full path with name of file returned in the function as an MD5 hash
    'called by HashString()
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath)
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToMD5 = ConvToBase64String(bytes)
    Else
        FileToMD5 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA1(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA1 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA1 = ConvToBase64String(bytes)
    Else
        FileToSHA1 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA256(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA2-256 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA256Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA256 = ConvToBase64String(bytes)
    Else
        FileToSHA256 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA384(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString()
    'parameter full path with name of file returned in the function as an SHA2-384 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA384Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA384 = ConvToBase64String(bytes)
    Else
        FileToSHA384 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Public Function FileToSHA512(sFullPath As String, Optional bB64 As Boolean = False) As String
    'called by HashString() and HashFolder()
    'parameter full path with name of file returned in the function as an SHA2-512 hash
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim enc, bytes
    
    Set enc = CreateObject("System.Security.Cryptography.SHA512Managed")
    'Convert the string to a byte array and hash it
    bytes = GetFileBytes(sFullPath) 'returned as a byte array
    bytes = enc.ComputeHash_2((bytes))
    
    If bB64 = True Then
        FileToSHA512 = ConvToBase64String(bytes)
    Else
        FileToSHA512 = ConvToHexString(bytes)
    End If
    
    Set enc = Nothing
    
End Function

Private Function GetFileBytes(ByVal sPath As String) As Byte()
    'called by all of the file hashing functions
    'makes byte array from file
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim lngFileNum As Long, bytRtnVal() As Byte
    
    lngFileNum = FreeFile
    
    If LenB(Dir(sPath)) Then ''// Does file exist?
        
        Open sPath For Binary Access Read As lngFileNum
        
        'a zero length file content will give error 9 here
        
        ReDim bytRtnVal(0 To LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53 'File not found
    End If
    
    GetFileBytes = bytRtnVal
    
    Erase bytRtnVal
    
End Function

Function ConvToBase64String(vIn As Variant) As Variant
    'called by all of the file hashing functions
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvToBase64String = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function ConvToHexString(vIn As Variant) As Variant
    'called by all of the file hashing functions
    'used to produce a hex output
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.Hex"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvToHexString = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function GetFileSize(sFilePath As String) As Double
    'called by CommandButton6_Click() and FilterOK() procedures
    'use this to test for a zero file size
    'takes full path as string in sFileSize
    'returns file size in bytes in nSize
    
    Dim fs As FileSystemObject, f As File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(sFilePath) Then
        Set f = fs.GetFile(sFilePath)
    Else
        GetFileSize = 99999
        Exit Function
    End If
    
    GetFileSize = f.Size
    
End Function

Sub ClearSheetFormats(sht As String)
    'called by CommandButton6_Click() and RunFileListing()
    'clears text only
    
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(sht)
    WS.Activate
    
    With WS
        .Activate
        .UsedRange.ClearFormats
        .Cells(1, 1).Select
    End With
    
    Set WS = Nothing

End Sub

Sub ClearSheetContents(sht As String)
    'called by CommandButton6_Click() and RunFileListing()
    'clears text only
    
    Dim WS As Worksheet
    
    Set WS = ThisWorkbook.Worksheets(sht)
    
    With WS
        .Activate
        .UsedRange.ClearContents
        .Cells(1, 1).Select
    End With
    
    Set WS = Nothing

End Sub

Sub FormatColumnsAToB(sSheet As String)
    'called by CommandButton6_Click()
    'formats and autofits the columns A to I
    
    Dim sht As Worksheet
    
    Set sht = ThisWorkbook.Worksheets(sSheet)
    sht.Activate
    'sht.Cells.Interior.Pattern = xlNone
    
    'add headings
    With sht
        .Range("a1").Formula = "Verified?:"
        .Range("b1").Formula = "File Path:"
        
        .Range("A1:B1").Font.Bold = True
        .Range("A2:B20000").Font.Bold = False
        .Range("A2:B20000").Font.Name = "Consolas"
    End With
    
    'autofit columns A to B
    With sht
        .Range("A1").Select
        .Columns("A:I").AutoFit
        .Range("A1").Select
        .Cells.FormatConditions.Delete 'reset any conditional formatting
    End With
    
    Set sht = Nothing

End Sub

Function MakeErrorLog(ByVal sIn As String, Optional sLogFilePath As String = "") As Boolean
    'called by RunFileListing()
    'Appends an error log string block (sIn) for the current hash run onto an error log.
    'If optional file path not given, then uses default ThisWorkbook path and default
    'file name are used.   The default name always has HashErr as its root,
    'with an added date-time stamp. If the proposed file path exists it will be used,
    'else it will be made.  The log can safely be deleted when full.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
    
    Dim fs, f, strDateTime As String, sFN As String
    
    'Make a date-time string
    strDateTime = Format(Now, "dddd, mmm d yyyy") & " - " & Format(Now, "hh:mm:ss AMPM")
    
    'select a default file name
    sFN = "HashErr.txt"
    
    'Create a scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'if path not given then get a default path instead
    If sLogFilePath = "" Then
        sLogFilePath = ThisWorkbook.path & "\" & sFN
    Else
        'some path was provided - so continue
    End If
    
    'Open file for appending text at end(8)and make if needed(1)
    On Error GoTo Err_Handler
    'set second arg to 8 for append, and 1 for read.
    Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
    Err.Clear
    
    'write to file
    f.Write "These " & nErrors & " Files Could Not be Hashed" & _
    vbCrLf & strDateTime & vbCrLf & _
    vbCrLf & sIn & vbCrLf
    
    'close file
    f.Close
    
    MakeErrorLog = True
    Exit Function
    
Err_Handler:
    If Err.Number = 76 Then 'path not found
        
        'make default path for output
        sLogFilePath = ThisWorkbook.path & "\" & sFN
        
        'Open file for appending text at end(8)and make if needed(1)
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
        
        'resume writing to file
        Resume Next
    Else:
        If Err.Number <> 0 Then
            MsgBox "Procedure MakeErrorLog has a problem : " & vbCrLf & _
            "Error number : " & Err.Number & vbCrLf & _
            "Error Description : " & Err.Description
        End If
        Exit Function
    End If
    
End Function

Function MakeHashLog(sIn As String, Optional ByVal sName As String = "HashFile") As Boolean
    'called by CommandButton6_Click() and RunFileListing()
    'Makes a one-time log for a hash run string (sIn) to be used for future verification.
    'If optional file path not given, then uses default ThisWorkbook path, and default
    'file name are used.   The default name always has HashFile as its root,
    'with an added date-time stamp. Oridinarily, such a block would be appended,
    'but the unique time stamp in the file name renders it single use.
    'If the file does not exist it will be made. The log can safely be deleted when full.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
    
    Dim fs, f, sFP As String, sDateTime As String
    
    'Make a date-time string
    sDateTime = Format(Now, "ddmmmyy") & "_" & Format(Now, "Hhmmss")
    
    'get path for log, ie path, name, number of entries, date-time stamp, suffix
    sFP = ThisWorkbook.path & "\" & sName & "_" & sDateTime & ".txt"
    
    'set scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'make and open file
    'for appending text (8)
    'make file if not exists (1)
    Set f = fs.OpenTextFile(sFP, 8, 1)
    
    'write record to file
    'needs vbNewLine charas added to sIn
    f.Write sIn '& vbNewLine
    
    'close file
    f.Close
    
    MakeHashLog = True
    
End Function

Function FilePathExists(sFullPath As String) As Boolean
    'called by CommandButton6_Click()
    'Returns true if the file path exists, else false.
    'Add a reference to "Microsoft Scripting Runtime"
    'in the VBA editor (Tools>References).
    
    Dim FSO As Scripting.FileSystemObject
    
    Set FSO = New Scripting.FileSystemObject
    
    If FSO.FileExists(sFullPath) = True Then
        'MsgBox "File path exists"
        FilePathExists = True
    Else
        'msgbox "File path does not exist"
    End If
    
End Function

Function HashString(ByVal sFullPath As String) As String
    'called by HashFolder()
    'Returns the hash string in function name, depending
    'on the userform option buttons. Used for hash run only.
    'Verification runs use a separate dedicated call.
    
    Dim b64 As Boolean
    
    'decide hex or base64 output
    If UserForm1.OptionButton3.Value = True Then
        b64 = False
    Else
        b64 = True
    End If
    
    'decide hash algorithm
    Select Case True
    Case UserForm1.OptionButton5.Value
        HashString = FileToMD5(sFullPath, b64)    'md5
    Case UserForm1.OptionButton6.Value
        HashString = FileToSHA1(sFullPath, b64)   'sha1
    Case UserForm1.OptionButton7.Value
        HashString = FileToSHA256(sFullPath, b64) 'sha256
    Case UserForm1.OptionButton8.Value
        HashString = FileToSHA384(sFullPath, b64) 'sha384
    Case UserForm1.OptionButton9.Value
        HashString = FileToSHA512(sFullPath, b64) 'sha512
    Case Else
    End Select
    
End Function

Function Algorithm() As String
    'called by RunFileListing()
    'Returns the algorithm string based on userform1 options
    'Used only for heading labels of sheet1
    
    Dim b64 As Boolean, sFormat As String
    
    'decide hex or base64 output
    If UserForm1.OptionButton3.Value = True Then
        b64 = False
        sFormat = " - HEX"
    Else
        b64 = True
        sFormat = " - Base64"
    End If
    
    'decide hash algorithm
    Select Case True
    Case UserForm1.OptionButton5.Value
        Algorithm = "MD5 HASH" & sFormat
    Case UserForm1.OptionButton6.Value
        Algorithm = "SHA1 HASH" & sFormat
    Case UserForm1.OptionButton7.Value
        Algorithm = "SHA256 HASH" & sFormat
    Case UserForm1.OptionButton8.Value
        Algorithm = "SHA384 HASH" & sFormat
    Case UserForm1.OptionButton9.Value
        Algorithm = "SHA512 HASH" & sFormat
    Case Else
    End Select
    
End Function

Function SelectFile(sTitle As String) As String
    'called by CommandButton5_Click()
    'opens a file-select dialog and on selection
    'returns its full path string in the function name
    'If Cancel or OK without selection, returns empty string
    
    Dim fd As FileDialog, sPathOnOpen As String
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    sPathOnOpen = "C:\Users\Internet Use\Documents\"
    
    'set the file-types list on the dialog and other properties
    fd.Filters.Clear
    fd.Filters.Add "All Files", "*.*"
    fd.Filters.Add "Excel workbooks", "*.log;*.txt;*.xlsx;*.xlsm;*.xls;*.xltx;*.xltm;*.xlt;*.xml;*.ods"
    fd.Filters.Add "Word documents", "*.log;*.txt;*.docx;*.docm;*.dotx;*.dotm;*.doc;*.dot;*.odt"
    fd.Filters.Add "Executable Files", "*.log;*.txt;*.exe"
        
    fd.AllowMultiSelect = False
    fd.InitialFileName = sPathOnOpen
    fd.Title = sTitle
    fd.InitialView = msoFileDialogViewList 'msoFileDialogViewSmallIcons
    
    'then, after pressing OK...
    If fd.Show = -1 Then ' a file has been chosen
        SelectFile = fd.SelectedItems(1)
    Else
        'no file was chosen - Cancel was selected
        'exit with proc name empty string
        'MsgBox "No file selected..."
        Exit Function
    End If
    
    'MsgBox SelectFile
    
End Function

Function GetAllFileText(sPath As String, sRet As String) As Boolean
    'called by CommandButton6_Click()
    'returns all text file content in sRet
    'makes use of Input method
    
    Dim Number As Integer
    
    'get next file number
    Number = FreeFile
    
    'Open file
    Open sPath For Input As Number
    
    'get entire file content
    sRet = Input(LOF(Number), Number)
    
    'Close File
    Close Number
    
    'transfers
    GetAllFileText = True
    
End Function

Sub NotesHashes()
    'not called
    'There are four main points in regard to GetFileBytes():
    'Does file exist:
    '1... If it does not exist then raises error 53
    ' The path will nearly always exist since it was just read from folders
    'so this problem is minimal unless the use of code is changed to read old sheets
    
    '2...If it exists but for some reason cannot be opened, protected, raises error 53
    'This one is worth dealing with - eg flash drives protect some files...xml
    'simple solution to filter out file type, but other solution unclear...
    'investigate filters for attributes and size?
    
    '3...if the file contents are zero - no text in a text file
    '- error 9 is obtained - subscripts impossible to set for array
    ' this is avoided by missing out a zero size file earlier
    'if there is even a dot in a file windows says it is 1KB
    'if there is only an empty string then it shows 0KB
    
    '4  The redim of the array should specify 0 to LOF etc in case an option base 1 is set
End Sub

See Also[edit]

External Links[edit]



Running the FCIV Utility from VBA

Summary[edit]

The Microsoft FCIV Utility, the File Checksum Integrity Verifier , is a free downloadable zipped package that allows a user to produce both SHA1 and MD5 hashes for any single file, a flat folder, or recursively for all files and folders. It can export its entire results package to a nominated .xml file. It can also conduct verification of file sets against a previously saved listing. It is used from a command prompt, but can be run using the Shell function from code like VBA, or from a batch file. For further reading in its use see: Availability and description of the File Checksum Integrity Verifier utility.

Making File Hash Listings[edit]

FCIV Hash Run at the Command Line[edit]

For completion, the command line code here will make an XML file of SHA1 hashes of the entire Documents folder. Omission of the xml term and the path that follows it will result in a screen listing. Notice the need for double quotes for paths that contain spaces.

The fciv utility is assumed here to reside in the FCIV folder.
c:\>FCIV\fciv.exe -r "C:\users\My Folder\Documents" -sha1 -xml "c:\users\My Folder\Documents\myhash.xml"

FCIV Hash Run from VBA[edit]

The Shell function in VBA has no Wait feature, so this line is best as the last. The quotes are a little different in this case from the usual VBA expectation. Note that all of the paths must be enclosed in two sets of double quotes and that the entire command line is enclosed in one set of double quotes. Assuming that the fciv.exe has been downloaded and installed as shown, this code line exports all of the hash strings for every file in the users Documents folder to the file myhash.xml. An exclusion file path could also have been added.

Notice that the use of VBA has some limitations, in that although an output can be made to a file with great success, verification output is limited to the command line processor. See examples on the page File Checksum Integrity Verifier (FCIV) Examples.

Sub FCIV()
   'runs the fciv function from VBA   
Dim Ret
   Ret = Shell("""c:\FCIV\fciv.exe"" -r ""C:\users\My Folder\Documents"" -sha1 -xml ""c:\users\My Folder\Documents\myhash.xml""")
End Sub

See Also[edit]

External Links[edit]



Use Log Files from VBA

Summary[edit]

At times it is useful to write strings to a text file from VBA. For example, for listing files, their hashes, or for simply logging errors. Text files are here intended to mean files with the .txt suffix. There are several procedures listed in the code module for both writing and reading such files.

Writing to Text Files and Logs[edit]

  • The procedure SendToLogFile APPENDS a string to a text file. The user optionally selects his own path and file name, but there is no OVERWRITE choice with this method. If user parameters are not given then the defaults are used. This procedure places the parameter string in line with a time date string, with each record entry on a new line.
  • The procedure LogError1 is intended to APPEND log errors, and is an example of the Print# statement. It is assumed here that the log file will always be placed in the same folder as the calling Workbook. As such, no path check is needed, and the minimum of coding applies. All formatting of the parameter text is assumed to be done externally. Readers can find format details for Print# in VBA help, and might also care to compare the advantages of using the Write# statement instead.
  • The procedure LogError2 is also intended to APPEND log errors and performs the same task as LogError1. It is however an example of the OpenTextFile method of the Scripting object. This procedure needs a reference in the VBA editor to Microsoft Scripting Runtime. Notice that this log will write every successive record into the first line unless vbNewLine characters are included at the end of the parameter string itself.
  • Procedure WriteToFile REPLACES any existing text, as opposed to appending it to any existing entries.
  • There are conventions in logging. Logging with a text file (.txt) means placing each record on the same line with the individual fields separated by a single tab character. The number of fields is the same for each record. Another convention is to use a comma-separated file format (.csv) where the fields are separated by commas instead of tabs. Both of these formats can be imported into MS Office applications,though users should pay particular attention as to how different log writing methods handle quotes.

Reading Text Files and Logs[edit]

  • VBA can also read text files into code for processing. However, once the notion of reading files is introduced, the choice of writing formats becomes more important. In addition, file reading can place more demands on error handling, and testing for path integrity.
  • The procedure GetAllFileText returns the entire contents of a .txt file . Readers should first confirm that the text file exists. File utilities elsewhere in this series would suit this purpose.
  • The procedure GetLineText returns an array of text file lines. The same comments regarding early file checks also apply in this case.

VBA Code[edit]

Option Explicit

Sub TestSendToLogFile()
    'Run this to test the making of a log entry
    Dim sTest As String
    
    'make a test string
    sTest = "Test String"
    
    'calling procedure - path parameter is optional
    SendToLogFile sTest

End Sub

Function SendToLogFile(ByVal sIn As String, Optional sLogFilePath As String = "") As Boolean
    'APPENDS the parameter string and a date-time string to next line of a log file
    'You cannot overwrite this file; only append or read.
    'If path parameter not given for file, or does not exist, defaults are used.
    'Needs a VBA editor reference to Microsoft Scripting Runtime
        
    Dim fs, f, strDateTime As String, sFN As String
    
    'Make a date-time string
    strDateTime = Format(Now, "dddd, mmm d yyyy") & " - " & Format(Now, "hh:mm:ss AMPM")
    
    'select a default file name
    sFN = "User Log File.txt"
    
    'Create a scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'if path not given then get a default path instead
    If sLogFilePath = "" Then
        sLogFilePath = ThisWorkbook.Path & "\" & sFN
    Else
        'some path was provided - so continue
    End If
    
    'Open file for appending text at end(8)and make if needed(1)
    On Error GoTo ERR_HANDLER
        'set second arg to 8 for append, and 1 for read.
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
    Err.Clear
        
    'write to file
    f.Write sIn & vbTab & strDateTime & vbCrLf
    
    'close file
    f.Close

    SendToLogFile = True
    Exit Function

ERR_HANDLER:
    If Err.Number = 76 Then 'path not found
        
        'make default path for output
        sLogFilePath = ThisWorkbook.Path & "\" & sFN
        
        'Open file for appending text at end(8)and make if needed(1)
        Set f = fs.OpenTextFile(sLogFilePath, 8, 1)
        
        'resume writing to file
        Resume Next
    Else:
        If Err.Number <> 0 Then
            MsgBox "Procedure SendToLogFile has a problem : " & vbCrLf & _
            "Error number : " & Err.Number & vbCrLf & _
            "Error Description : " & Err.Description
        End If
        Exit Function
    End If

End Function

Function LogError1(sIn As String) As Boolean
    'APPENDS parameter string to a text file
    'assumes same path as calling Excel workbook
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim sPath As String, Number As Integer
    
    Number = FreeFile 'Get a file number
    sPath = ThisWorkbook.Path & "\error_log1.txt" 'modify path\name here
    
    Open sPath For Append As #Number
    Print #Number, sIn
    Close #Number

    LogError1 = True
    
End Function

Function WriteToFile(sIn As String, sPath As String) As Boolean
    'REPLACES all content of text file with parameter string
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim Number As Integer
    
    Number = FreeFile 'Get a file number
    
    'write string to file
    Open sPath For Output As #Number
    Print #Number, sIn
    Close #Number

    WriteToFile = True
    
End Function

Function LogError2(sIn As String) As Boolean
    'Scripting Method - APPENDS parameter string to a text file
    'Needs VBA editor reference to Microsoft Scripting Runtime
    'assumes same path as calling Excel workbook
    'makes file if does not exist
    'no layout or formatting - assumes external
    
    Dim fs, f, sFP As String
    
    'get path for log
    sFP = ThisWorkbook.Path & "\error_log2.txt"
    
    'set scripting object
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    'make and open file
    'for appending text (8)
    'make file if not exists (1)
    Set f = fs.OpenTextFile(sFP, 8, 1)
            
    'write record to file
    'needs vbNewLine charas added to sIn
    f.Write sIn '& vbNewLine
        
    'close file
    f.Close

    LogError2 = True
    
End Function

Sub TestGetAllFileText()
    'run this to fetch text file contents
    
    Dim sPath As String, sRet As String, vRet As Variant
    
    sPath = "C:\Users\Your Folder\Documents\test.txt"
    
    'check that file exists - see file utilities page
    'If FileFound(sPath) Then
        If GetAllFileText(sPath, sRet) = True Then
            MsgBox sRet
        End If
    'Else
       'MsgBox "File not found"
    'End If

End Sub

Function GetAllFileText(sPath As String, sRet As String) As Boolean
    'returns all text file content in sRet
    'makes use of Input method
    
    Dim Number As Integer

    'get next file number
    Number = FreeFile

    'Open file
    Open sPath For Input As Number

    'get entire file content
    sRet = Input(LOF(Number), Number)
    
    'Close File
    Close Number

    'transfers
    GetAllFileText = True

End Function

Sub TestGetLineText()
    'run this to fetch text file contents
    
    Dim sPath As String, sRet As String, vRet As Variant
    Dim n As Long
    sPath = "C:\Users\Internet Use\Documents\test.txt"
    
    'check that file exists - see file utilities page
    'If FileFound(sPath) Then
        'print text files lines from array
        If GetLineText(sPath, vRet) = True Then
            For n = LBound(vRet) To UBound(vRet)
                Debug.Print vRet(n)
            Next n
        End If
    'Else
       'MsgBox "File not found"
    'End If

End Sub

Function GetLineText(sPath As String, vR As Variant) As Boolean
    'returns all text file lines in array vRet
    'makes use of Input method
    
    Dim Number As Integer, sStr As String
    Dim vW As Variant, sF As String, n As Long
    
    'redim array
    ReDim vW(0 To 1)
    
    'get next file number
    Number = FreeFile

    'Open file
    Open sPath For Input As #Number

    'loop though file lines
    Do While Not EOF(Number)
        n = n + 1
        Line Input #Number, sStr
        ReDim Preserve vW(1 To n)
        vW(n) = sStr
        'Debug.Print sStr
    Loop
    
    'Close File
    Close #Number
    
    'transfers
    vR = vW
    GetLineText = True

End Function



Message Boxes

Summary[edit]

This code block contains a message box function for YES, NO or CANCEL.

VBA Code[edit]

Option Explicit
Sub TestYesNoCancel()
    'run to test message box
    
    Dim bDefault As Boolean
    
    If YesNoCancel(bDefault) = True Then
        If bDefault Then
            'do default stuff
            MsgBox "Using default"
        Else
            'do other stuff
            MsgBox "Using other"
        End If
    Else
           'do cancelled stuff
        MsgBox "User cancelled"
        Exit Sub
    End If
End Sub

Function YesNoCancel(bDefault As Boolean) As Boolean
    'Message box for yes, no, or cancel

    Dim Msg As String, Style As Long, Title As String
    Dim Reply As Integer

    'assignments
    Msg = "Do you want the default ?" & vbNewLine & vbNewLine & _
          "Select :" & vbNewLine & _
          "YES ;  for the default," & vbNewLine & _
          "NO ;   for some other," & vbNewLine & _
          "CANCEL ;  to quit."                              'message
    Style = vbYesNoCancel + vbQuestion + vbDefaultButton1   'buttons.
    Title = "Yes, No, Cancel layout..."                     'title.

    'show message box
    Reply = MsgBox(Msg, Style, Title)

    'resolve choice
    Select Case Reply
    Case vbYes
        bDefault = True
        YesNoCancel = True
    Case vbNo
        YesNoCancel = True
        Exit Function
    Case vbCancel
        Exit Function
    End Select

End Function

See Also[edit]

External Links[edit]



Input Boxes

Summary[edit]

This code block contains an input box function. It includes a number of fairly common validation routines that are selected within the main procedure.

VBA Code[edit]

Option Explicit

Sub TestGetAnInput()
    'run to test input box functions
    
    Dim vR As Variant, bC As Boolean
    
    If GetAnInput(vR, bC) Then
        MsgBox vR
    ElseIf bC = True Then MsgBox "Cancel or too many attempts"
    Else
        MsgBox "Input must be an integer"
    End If
    
End Sub

Function GetAnInput(vRet As Variant, bCancel As Boolean) As Boolean
    '================================================================================
    'Input box function - gets an input from user with choice of validation, or none.
    'Returns value in vRet and funcion True, or bCancel = true and function False.
    'With bUseValidation = True, loops until success, cancel, or 3 failed attempts.
    'With bUseValidation = False, returns first entry without validation.
    'Enable chosen validation function below.
    '================================================================================
    
    Dim Reply As Variant, bValidated As Boolean, n As Long, bUseValidation As Boolean
    Dim sMsg As String, sTitle As String, sDefault As String
    Dim nS As Integer, nE As Integer
        
    'set assignments
    sMsg = "Enter an integer..."
    sTitle = "Input box..."
    sDefault = "1234567890"
    n = 1
    nS = 32: nE = 126 'printing chara set 32-126
    bUseValidation = False 'use validation at all?
    
    Do  'get user input
        Reply = InputBox(sMsg, sTitle, sDefault)
        
        'test if validation needed
        If bUseValidation = False Then
            bValidated = True
            Exit Do
        End If

        'control number of attempts
        If n >= 3 Then 'set attempt limit here
            Exit Do
        End If
        n = n + 1
        
        'add validation by removing comment on one function call
        ' ========================================================
        '            ENABLE ONLY ONE VALIDATION FUNCTION
        ' ========================================================
        ' If IsNumeric(Reply) Then bValidated = True
        ' If IsAnInteger(Reply) Then bValidated = True
        ' If IsADate(Reply) Then bValidated = True
        ' If IsLikeCustomFormat(Reply) Then bValidated = True
        ' If IncludesAscRange(Reply, nS, nE) Then bValidated = True
        ' If ExcludesAscRange(Reply, nS, nE) Then bValidated = True
        ' If IsAllInAscRange(Reply, nS, nE) Then bValidated = True
        '=========================================================
    
    Loop Until bValidated = True Or Reply = ""
    
    'transfers
    If bValidated Then
        vRet = Reply       'got one
        GetAnInput = True
    ElseIf Reply = "" Then 'cancelled
        bCancel = True
    Else                   'too many tries
        bCancel = True
    End If
    
End Function

Function IsAnInteger(ByVal vIn As Variant) As Boolean
    'returns true if input contains an integer

    'check if numeric
    'numeric excludes dates and booleans
    If IsNumeric(vIn) Then
           'check long version against original
           If vIn = CLng(vIn) Then
               IsAnInteger = True
           End If
    End If

End Function

Function IsADate(ByVal vIn As Variant) As Boolean
    'returns true if input contains a date

    'check if date
    If IsDate(vIn) Then
        IsADate = True
    End If

End Function

Function IsAllInAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if entire string lies in asci parameter range
    
    Dim n As Long, sS As String, sAccum As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'accumulate all validated charas
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                sAccum = sAccum & sS
        End Select
    Next n
     
    If Len(sAccum) = Len(vIn) Then
        IsAllInAscRange = True
    End If

End Function

Function IncludesAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if any part of string lies in asci parameter range
    
    Dim n As Long, sS As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'early exit for first inclusion found
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                'found - so exit
                IncludesAscRange = True
                Exit Function
        End Select
    Next n
     
End Function

Function ExcludesAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if input does not contain any part of asci parameter range
    
    Dim n As Long, sS As String, sAccum As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'early exit for first inclusion found
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                'found - so exit
                sAccum = sAccum & sS
        End Select
    Next n
     
    If sAccum = "" Then
        ExcludesAscRange = True
    End If

End Function

Function IsLikeCustomFormat(ByVal vIn As Variant) As Boolean
    'returns true if input pattern is like internal pattern
    
    Dim sPattern As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    'specify the pattern - see help for Like operator
    sPattern = "CAT###-[a-z][a-z]#" 'for example CAT123-fg7
    
    'test the pattern against input
    IsLikeCustomFormat = vIn Like sPattern
     
End Function

See Also[edit]

External Links[edit]



Pseudo Random Repeated Substrings

Summary[edit]

This page describes some matters that apply to the Rnd() function of VBA. In particular it illustrates that repeated substrings can result when the Randomize() function is wrongly positioned inside the same loop as Rnd(), instead of before it.

The VBA Rnd() Function[edit]

  • The Rnd() function is pseudo random, as opposed to true random . True randomness is found rarely, one notable example being the sequence of data that can be derived from white noise. White noise, like the radio noise from the sun or perhaps the unintentional noise in a radio or other electronic device, has a fairly uniform distribution of frequencies, and can be exploited to produce random distributions of data; also known as linear probability distributions because their frequency distributions are straight lines parallel to the horizontal axis.
  • Pseudo randomness can be obtained with a feedback algorithm, where a sequence of output values of a function is fed back and assists in the making of the next part of an output stream. These are referred to as pseudo random number generators (PRNG). Such a process, although complex, is nonetheless determinate, being based entirely on its starting value. Such generators, depending on their design can produce long sequences of values, all unique, before the entire stream eventually repeats itself.
  • A PRNG output stream will always repeat itself if a long enough set of values is generated. The Rnd function in VBA can generate a sequence of up to 16,777,216 numbers before any one number is repeated, at which time the entire sequence itself is repeated. This is adequate in most cases. The Rnd() function has been described by Microsoft as belonging to the set of PRNGs called Linear Congruential Generators (LCG), though it is unclear as to whether or not the algorithm has since been modified.
  • The Rnd function is not suitable for large tables or for cryptographic use, and VBA itself is quite insecure in its own right. For given starting values the generator always will produce the same sequence. Clearly, if any part of the stream is known, this allows other values in the sequence to be predicted, and this state of affairs is insecure for cryptographic use. Perhaps surprisingly, modeling methods that make much use of random values need even longer unique sequences than that produced by Rnd().
  • The exact coding of the Microsoft Rnd() function is not available, and their descriptive material for it is quite sketchy. A recent attempt by me to implement the assumed algorithm in VBA code failed because of overflow, so those who intend to study such generators in VBA need to use another algorithm. Perhaps study of the Wichmann-Hill (1982) CLCG algorithm, that can be implemented in VBA would be a better choice. A VBA implementation, (by others), of the Wichmann-Hill (1982) algorithm is provided in another page of this series, along with some simpler generator examples.

Worst Case for Rnd() Substrings?[edit]

  • A well designed PRNG stream consists of unique numbers, but this applies only to the designer's unfiltered set of numbers in the range from zero to unity, [0,1]. As soon as we start to take some values from the stream, and ignore others, say to make custom outputs, the new steams will take on different characteristics. The combination of cherry-picking elements from the natural sequence and the mapping of a large set to a very small set takes its toll. When observing the new set, the count of characters to the cycle repeat point shortens, and the number of repeated substrings increases throughout the set.
  • The code listing below allows checking of a Rnd() stream for substrings, using preset filter settings, eg; capitals, lower case, integers, etc., and in addition, includes a similar generator based on a hash for those who would like to compare it.
  • The repeat substring procedure is quite slow, depending as it does on the location of repeats. The worst case is for no repeats found where the number of cycles becomes maximum at (0.5*n)^2, the square of half the number of characters in the test string. Of course the smallest number of cycles is just one when a simple string is repeated, eg; abcabc. Clearly, an increase of string length by a factor of ten could increase the run time by a factor of one hundred. (1000 characters in about 2 seconds, 2000 in 4secs, 10000 in 200secs, is, so far, the best timing!).
  • Coding layout can affect the length of repeated substrings too. The reader might compare the effect of placing the Randomize function outside the random number loop, then inside the loop, while making an output of only capitals. (See code in MakeLongRndStr). In the past the repeat strings have worsened considerably when placed within. The code as listed here to test Rnd() with 1000 samples of capitals, no use of DoEvents, and Randomize wrongly placed inside the loop, will return a repeat substring of up to four hundred characters for this author. Increasing the code lines in the loop, affecting the time (?) for each iteration of the loop to run, also affects the length of any substrings.
Option Explicit

Sub TestRndForRepeats()
    'run this to make a pseudo random string
    'and to test it for longest repeated substring
    
    Dim strRnd As String, sOut As String
    Dim nOut As Long, nLen As Long
    
    strRnd = MakeLongRndStr(1000)
    MsgBox strRnd,, "Long string..."
    
    sOut = LongestRepeatSubstring(strRnd, nOut)
    
    MsgBox "Repeated substring found is : " & _
       vbCrLf & sOut & vbCrLf & _
       "Number of these found : " & nOut & vbCrLf & _
       "Length of each : " & Len(sOut),, "Repeat substring..."

End Sub

Sub TestHashForRepeats()
    'run this to make a long hash-based output
    'and to test it for longest repeated substring
    
    Dim sOut As String, sHash As String, nOut As Long
    
    sHash = LongHash("String to hash", 1000)
    
    MsgBox "The following sha256-based hash has " & _
           Len(sHash) & " characters." & _
           vbCrLf & vbCrLf & sHash,, "Long hash..."

    sOut = LongestRepeatSubstring(sHash, nOut)
    
    MsgBox "Repeated substring found is : " & _
       vbCrLf & sOut & vbCrLf & _
       "Number of these found : " & nOut & vbCrLf & _
       "Length of each : " & Len(sOut),, "Repeat substring..."

End Sub

Function MakeLongRndStr(nNumChr As Long) As String
    'Makes a long capital letters string using rnd VBA function
    
    Dim n As Long, sChr As String, nAsc As Long
    Dim nSamp As Long, sRec As String
    
    '========================================================================
    ' Notes and Conclusions:
    ' The VBA function rnd is UNSUITED to generation of long random strings.
    ' Both length and number of repeats increases rapidly near 256 charas.
    ' Reasonable results can be obtained by keeping below 128 characters.
    ' For longer strings, consider hash-based methods of generation.
    '========================================================================
    'Randomize 'right place
    Do Until n >= nNumChr
        'DoEvents
        Randomize 'wrong place
        nSamp = Int((122 - 48 + 1) * Rnd + 48) 'range includes all charas
        sChr = Chr(nSamp)
        
        'cherry-picks 10, 26, 36, 52, or 62 from a set of 75
        Select Case nSamp 'chara filter
                Case 65 To 90  'upper case letters
                    sRec = sRec & sChr
                Case 48 To 57  'integers
                    'sRec = sRec & sChr
                Case 97 To 122 'lower case letters
                    'sRec = sRec & sChr
                Case Else
                    'disregard
        End Select
        n = Len(sRec)
    Loop
    
    'MsgBox sAccum
    
    MakeLongRndStr = Left$(sRec, nNumChr)

End Function

Function LongHash(sIn As String, nReq As Long, Optional sSeed As String = "") As String
    'makes a long sha256 hash - length specified by user
    'Parameters: sIn;   the string to hash
                'nReq;  the length of output needed
                'sSeed; optional added string modifier
    
    Dim n As Long, m As Long, c As Long, nAsc As Integer, sChr As String
    Dim sF As String, sHash As String, sRec As String, sAccum As String
    
    Do Until m >= nReq
        DoEvents
        n = n + 1 'increment
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
        'you set your own cycle increment here
        sF = sIn & sSeed & sAccum & (7 * n * m / 3)
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
        'get a single hash of sF
        sHash = HashSHA256(sF)
        'filter output for chara type
        For c = 1 To Len(sHash)
            sChr = Mid$(sHash, c, 1)
            nAsc = Asc(sChr)
            'cherry-picks 10, 26, 36 ,52, or 62 from a set of 64
            Select Case nAsc 'chara filter
                Case 65 To 90  'upper case letters
                    sRec = sRec & sChr
                Case 48 To 57  'integers
                    'sRec = sRec & sChr
                Case 97 To 122 'lower case letters
                    'sRec = sRec & sChr
                Case Else
                    'disregard
            End Select
        Next c
        'accumulate
        sAccum = sAccum & sRec
        m = Len(sAccum)
        sRec = "" 'delete line at your peril!
    Loop
    
    LongHash = Left$(sAccum, nReq)

End Function

Function HashSHA256(sIn As String) As String
    'Set a reference to mscorlib 4.0 64-bit
    'HASHES sIn string using SHA2-256 algorithm
    
    'NOTE
    'total 88 output text charas of base 64
    'Standard empty string input gives : 47DEQpj8HBSa+/...etc,
    
    Dim oT As Object, oSHA256 As Object
    Dim TextToHash() As Byte, bytes() As Byte
    
    Set oT = CreateObject("System.Text.UTF8Encoding")
    Set oSHA256 = CreateObject("System.Security.Cryptography.SHA256Managed")
    
    TextToHash = oT.GetBytes_4(sIn)
    bytes = oSHA256.ComputeHash_2((TextToHash))
    
    HashSHA256 = ConvB64(bytes)
    
    Set oT = Nothing
    Set oSHA256 = Nothing
   
End Function

Function ConvB64(vIn As Variant) As Variant
    'used to produce a base-64 output
    'Set a reference to mscorlib 4.0 64-bit
    
    Dim oD As Object
    
    Set oD = CreateObject("MSXML2.DOMDocument")
    With oD
        .LoadXML "<root />"
        .DocumentElement.DataType = "bin.base64"
        .DocumentElement.nodeTypedValue = vIn
    End With
    ConvB64 = Replace(oD.DocumentElement.Text, vbLf, "")
    
    Set oD = Nothing
    
End Function

Function LongestRepeatSubstring(sIn As String, Optional nSS As Long) As String
    'finds longest repeated non-overlapping substring and number of repeats
    'greatest number cycles = (0.5*n)^2 for when "none found", eg; abcdef (9)
    'shortest number cycles = 1 for one simple duplicated string; eg abcabc
    
    Dim s1 As String, s2 As String, X As Long
    Dim sPrev As String, nPrev As Long, nLPrev As Long
    Dim nL As Long, nTrial As Long, nPos As Long, vAr As Variant
        
    nL = Len(sIn)
    For nTrial = Int(nL / 2) To 1 Step -1
        DoEvents
        For nPos = 1 To (nL - (2 * nTrial) + 1)
            X = 0
            s1 = Mid(sIn, nPos, nTrial)
            s2 = Right(sIn, (nL - nPos - nTrial + 1))
            vAr = Split(s2, s1)
            X = UBound(vAr) - LBound(vAr)
            If X > 0 Then
                If nPrev < X Then
                    sPrev = s1
                    nPrev = X
                End If
            End If
        Next nPos
        If nPrev <> 0 Then
            LongestRepeatSubstring = sPrev
            nSS = nPrev
            Exit Function
        End If
    Next nTrial
End Function




A PRNG for VBA

Summary[edit]

  • Pseudo-random generators of the Microsoft's Rnd() type, if run for long enough, generate a characteristic sequence that is based on numbers chosen within their coding. Such a sequence is repeated in its entirety and is invariant. The Rnd() function of VBA, if placed in a loop without a parameter, and without making use of Randomize() at all, will generate 16777216 values between zero and unity, then start again at the beginning, making one identical sequence. The only option for the user is to choose the part of that one solitary sequence that he will use for the start of his sample list. This is done by choosing a start value or seed. In the case of Rnd(), the start value is chosen in various ways; by default, using the system timer, or with a user-set number. Again, the start parameters that are set by the user do not make new sequences, they just decide which bit of one long sequence will be used. Linear Congruential Number Generators (LCNG), the type used by Microsoft's Rnd() function are described in detail at Linear congruential generator.
  • The maximum cycle length for a single stage LCNG generator is equal to its modulus, and for combined algorithms it is roughly equal to the product of the moduli of the various stages. Whereas a well designed generator will have the maximum cycle length and consist only of unique values throughout its sequence, not all generators do this. The above link describes the design values required to make a generator with a maximum cycle over all of its starting values.
  • The code module below contains the Wichmann-Hill (1982) CLCNG (combined LCNG) in VBA, and is fully functional. It is called RndX(), and is used in conjunction with its own RandomizeX(). It has a much longer repeat cycle than Microsoft's Rnd(). A summary of the most useful settings for RndX() is given, with additional details for those who need them in a drop box. Sadly, this author lacks the tools and knowledge for any serious testing of number generators, so the offerings below are likely to be of interest to only beginners.
  • Long cycle generators are awkward to study in VBA. The lengths of both Microsoft's Rnd() and the user function RndX() are much too long to write to a single worksheet column. The solution is either to list only parts of long streams or to make a number generator with a cycle short enough for a full listing. Listing in a single column this way allows confirmation of the repeat cycle length, then after trimming the rows to a complete set, counting rows after the removal of duplicates will confirm for the skeptical that all of the values are unique. A module is included with procedures to list one section of the Wichmann-Hill implementation, that fits into about 30269 rows or so, and another with a very simple generator for further testing, that fits into just 43.

Microsoft's Rnd() algorithm[edit]

Microsoft's Visual Basic for Applications (VBA), at present uses a linear congruential generator (LCG) for pseudo-random number generation in the Rnd() function. Attempts to implement the Microsoft algorithm in VBA failed owing to overflow. The following is its basic algorithm.

      x1 = ( x0 * a + c ) MOD m
  and;       
      Rnd() = x1/m
  where:
      Rnd() = returned value
      m = modulus = (2^24)
      x1 = new value
      x0 = previous value (initial value 327680)
      a = 1140671485
      c = 12820163
      Repeat length = m = (2^24) = 16,777,216

Similarities will be noticed between Microsoft's Rnd() and the one below, described by Wichmann-Hill (1982), in which a sum of three LCG expressions is used in the production of each output number. The combination of expressions gives RndX(), with the coded values, its much improved cycle-repeat-length of about:

      Repeat length = m1 * m2 * m3 = 30269 * 30307 * 30323 = 27,817,185,604,309

VBA Code - Wichmann-Hill (1982)[edit]

A reminder about module level variables may be in order. Module level variables hold their values between procedure runs. In fact they will retain values until the VBA is no longer used at all or the code is edited. The code has been laced with resets for these variables, to ensure starting with intended values, as opposed to old stored ones from the previous top procedure runs.

On a cautionary note; although this algorithm has improved properties over the resident Rnd(), the applications on which these generators are run are not particularly secure. Consider also that the output of all LCNG coding is entirely predictable if the starting value is ever known. In fact, if any part of such a stream is known, then it is possible for those who intend harm to find the entire stream by comparing it with stored values. These facts when taken together limit the use of such a VBA implementation to study or non-critical applications.

That said, these are likely to be the most useful parameter configurations: In each case RandomizeX() should only be called once, before and outside any generator loop that contains RndX(). This advice also applies to the Microsoft function Rnd() and its companion Randomize().

  • To produce outputs with an unpredictable start point, and a different start point each time it is run:
    • Call RandomizeX without any parameter before calling RndX, also without any parameter. This uses the system timer.
  • To produce outputs from a large set of start points, repeatable, and chosen by a user parameter:
    • Call RandomizeX with any numeric parameter before calling RndX without any parameter. Changed RandomizeX parameter values result in different start points of the standard algorithm stream.
  • To produce an unpredictable, single value, different each time it is run:
    • Call RandomizeX without any parameter before calling RndX with a parameter of zero. This uses the system timer.
  • To produce a repeatable single value, related to, and chosen by a user parameter:
    • Call RandomizeX with any numeric parameter before calling RndX with a parameter of zero. Changed RandomizeX parameter values result in different values that are peculiar to each parameter.
  • Refer to the drop box below for a complete tabulation of the parameter settings and their outcomes.
PRNG RndX() and RandomizeX() Parameter Details
 
RndX() and RandomizeX() Parameter Details
RandomizeX()
parameter
RndX()
parameter
Behaviour of function
(assuming coding is to produce a sequence)
none. none PRNG stream determined by runtime sampling of the computer’s system timer. Stream uncertain.
none positive PRNG stream determined by runtime sampling of the computer’s system timer. Stream uncertain. Positive parameters of RndX() do not affect it at all.
none negative One number, repeatable, and each one different and depending on the value of RndX() parameter.
Example; RndX(-3) leads to 0.05079271
none zero One number, repeatable, decided by runtime sampling of the computer’s system timer;
Example; sequence is 0.1741…, 01741…
numeric2 none PRNG stream, repeatable, and each one different and depending on the value of RandomizeX() parameter.
numeric positive PRNG stream, repeatable, and each one different and depending on the value of RandomizeX() parameter. Positive parameters of RndX() do not affect it at all.
numeric negative One number, repeatable, and each one different and depending on the value of RndX() parameter. The RandomizeX() parameter value has no effect at all.
Example; RndX(-51) leads to 0.8634…
numeric zero One number, repeatable, and each one different and depending on the value of RandomizeX() parameter.
Example; RandomizeX(2346) leads to 0.2322…
function
not used
none Default PRNG stream, repeatable, and always same.
Example; sequence is 0.8952…, 0.1114…, 0.9395…
function
not used
positive Default PRNG stream, repeatable, and always same.
Example; sequence is 0.8952…, 0.1114…, 0.9395…
function
not used1
negative
or zero
One number, repeatable, and each one different and depending on the value of RndX() parameter.
Example; RndX(0) = 0.8694...: -5 = 0.0846…


1. The term Function not used is intended to mean that the function is not specifically called in code by the user. In some cases, for example this one, the RandomizeX() function still needs to be available in code for the RndX() function's internal call.
2. Numeric items are those that can be made into a number. The RandomizeX() function produces a positive integer using the seed value given in its variant parameter. It does this for any leading part of a string also, right up to the first character that cannot be recognized as numeric.

Padding.gif

Padding.gif


The code in this section should be saved as a separate standard module in Excel.

Option Explicit
Dim nSamples As Long
Dim nX As Long, nY As Long, nZ As Long

Sub TestRndX()
    'run this to obtain RndX() samples
    'Wichmann, Brian; Hill, David (1982), Algorithm AS183:
    'An Efficient and Portable Pseudo-Random Number Generator,
    'Journal of the Royal Statistical Society. Series C
    Dim n As Long
   
    'reset module variables
    nX = 0: nY = 0: nZ = 0
    
    RandomizeX
    For n = 1 To 10
        Debug.Print RndX()
        MsgBox RndX()
    Next n
   
    'reset module variables
    nX = 0: nY = 0: nZ = 0

End Sub

Sub TestScatterChartOfPRNG()
    'run this to make a point scatter chart
    'using samples from RndX
    
    Dim vA As Variant, n As Long
    Dim nS As Long, nR As Double
    
    'remove any other charts
    'DeleteAllCharts
    
    'reset module variables
    nX = 0: nY = 0: nZ = 0
    
    'set number of samples here
    nSamples = 1000
    ReDim vA(1 To 2, 1 To nSamples) 'dimension array
        
    'load array with PRNG samples
    RandomizeX
    For n = 1 To nSamples
        nR = RndX()
        vA(1, n) = n  'x axis data - sample numbers
        vA(2, n) = nR 'y axis data - prng values
    Next n
    
    'make scatter point chart from array
    ChartScatterPoints vA, 1, 2, nSamples & " Samples of RndX()", _
                "Sample Numbers", "PRNG Values [0,1]"
    
    'reset module work variables
    nX = 0: nY = 0: nZ = 0

End Sub

Sub RandomizeX(Optional ByVal nSeed As Variant)
   'sets variables for PRNG procedure RndX()
      
   Const MaxLong As Double = 2 ^ 31 - 1
   Dim nS As Long
   Dim nN As Double
   
   'make multiplier
   If IsMissing(nSeed) Then
      nS = Timer * 60
   Else
      nN = Abs(Int(Val(nSeed)))
      If nN > MaxLong Then 'no overflow
         nN = nN - Int(nN / MaxLong) * MaxLong
      End If
      nS = nN
   End If
   
   'update variables
   nX = (nS Mod 30269)
   nY = (nS Mod 30307)
   nZ = (nS Mod 30323)
   
   'avoid zero state
   If nX = 0 Then nX = 171
   If nY = 0 Then nY = 172
   If nZ = 0 Then nZ = 170

End Sub

Function RndX(Optional ByVal nSeed As Long = 1) As Double
   'PRNG - gets pseudo random number - use with RandomizeX
   'Wichmann-Hill algorithm of 1982
   
   Dim nResult As Double
   
   'initialize variables
   If nX = 0 Then
      nX = 171
      nY = 172
      nZ = 170
   End If
   
   'first update variables
   If nSeed <> 0 Then
      If nSeed < 0 Then RandomizeX (nSeed)
      nX = (171 * nX) Mod 30269
      nY = (172 * nY) Mod 30307
      nZ = (170 * nZ) Mod 30323
   End If
   
   'use variables to calculate output
   nResult = nX / 30269# + nY / 30307# + nZ / 30323#
   RndX = nResult - Int(nResult)

End Function

Sub ChartScatterPoints(ByVal vA As Variant, RowX As Long, RowY As Long, _
                     Optional sTitle As String = "", Optional sXAxis As String, _
                     Optional sYAxis As String)
    
    'array input must contain two data rows for x and y data
    'parameters for user title, x axis and y axis labels
    'makes a simple point scatter chart
    
    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long, bOptLim As Boolean
    Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
    
    LBR = LBound(vA, 1): UBR = UBound(vA, 1)
    LBC = LBound(vA, 2): UBC = UBound(vA, 2)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)
    
    'labels for specific charts
    If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
    If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
    If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
    
    If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
        MsgBox "Parameter data rows out of range in ChartColumns - closing"
        Exit Sub
    End If
    
    'transfer data to chart arrays
    For n = LBC To UBC
        X(n) = vA(RowX, n) 'x axis data
        Y(n) = vA(RowY, n) 'y axis data
    Next n
    
    'make chart
    Charts.Add
    
    'set chart type
    ActiveChart.ChartType = xlXYScatter 'point scatter chart
        
    'remove unwanted series
    With ActiveChart
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With
    
    
    'assign the data and labels to a series
    With ActiveChart.SeriesCollection
        If .Count = 0 Then .NewSeries
            If Val(Application.Version) >= 12 Then
                .Item(1).Values = Y
                .Item(1).XValues = X
            Else
                .Item(1).Select
                Names.Add "_", X
                ExecuteExcel4Macro "series.x(!_)"
                Names.Add "_", Y
                ExecuteExcel4Macro "series.y(,!_)"
                Names("_").Delete
            End If
    End With
        
    'apply title string, x and y axis strings, and delete legend
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Text = sT
        .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
        .Axes(xlCategory).AxisTitle.Text = sX
        .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
        .Axes(xlValue).AxisTitle.Text = sY
        .Legend.Delete
    End With
    
    'trim axes to suit
    With ActiveChart
    'X Axis
        .Axes(xlCategory).Select
        .Axes(xlCategory).MinimumScale = 0
        .Axes(xlCategory).MaximumScale = nSamples
        .Axes(xlCategory).MajorUnit = 500
        .Axes(xlCategory).MinorUnit = 100
        Selection.TickLabelPosition = xlLow
        
    'Y Axis
        .Axes(xlValue).Select
        .Axes(xlValue).MinimumScale = -0.2
        .Axes(xlValue).MaximumScale = 1.2
        .Axes(xlValue).MajorUnit = 0.1
        .Axes(xlValue).MinorUnit = 0.05
    End With
    
    
    ActiveChart.ChartArea.Select
    
    Set oC = Nothing

End Sub

Sub DeleteAllCharts5()
    'run this to delete all ThisWorkbook charts
    
    Dim oC
       
    Application.DisplayAlerts = False
    
    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC
    
    Application.DisplayAlerts = True
    
End Sub

Simpler Tests of PRNGs[edit]

The code module below contains a stripped down version of the Wichmann-Hill (1982) algorithm, in fact using only the first of its three calculated sections. It will make several complete streams of values on Sheet1 of the workbook in which it is run, using different start values. Notice that the first values are all repeated at row 30269, as will the whole stream if extended. After producing the list, use the spreadsheet's functions for column sorting and the removal of duplicates to see that each column contains the appropriate number of unique entries. An even simpler generator with a repeat cycle of just 43 is also included that might make study more manageable, and the cycle of Microsoft's Rnd() can be seen to repeat at 16777216 (+1) by running TestMSRnd.

The code in this section should be saved as a separate standard module in Excel.

Option Explicit

Private ix2 As Long

Sub TestWHRnd30269()
    'makes five columns for complete output streams
    'each with a different start point
    'runs a simplified LCNG with mod 30269
        
    Dim sht As Worksheet, nS As Double, nSamp As Long
    Dim c As Long, r As Long, nSeed As Long
    
    'set seed value for Rnd2()
    nSeed = 327680 'WH initial seed
    
    'set number of random samples to make
    nSamp = 30275 '30269 plus say, 6
    
    'set initial value of carry variable
    ix2 = nSeed
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'clear the worksheet
    sht.Cells.Cells.ClearContents
    
    'load sheet with set of samples
    For c = 1 To 5                'number of runs
        ix2 = nSeed + c           'change start value
        For r = 1 To nSamp        'number of samples
            nS = WHRnd30269()     'get a sample
            sht.Cells(r, c) = nS  'write to sheet
        Next r
    Next c

    sht.Cells(1, 1).Select

End Sub

Function WHRnd30269() As Double
   'first part of Wichmann-Hill tripple.
   'When started with seed ix2 = 171,
   'full sequence repeats from n = 30269
   'without any repeated values before.
   
   Dim r As Double
   
   'ix2 cannot be 0.
   If ix2 = 0 Then
      ix2 = 171
   End If
   
   'calculate Xn+1 from Xn
   ix2 = (171 * ix2) Mod 30269
   
   'make an output value
   r = ix2 / 30269#
   WHRnd30269 = r - Int(r)

End Function

Sub TestSimpleRnd43()
    'makes five columns for complete output streams
    'each with a different start point
    'runs a very simple LCNG with mod 43
        
    Dim sht As Worksheet, nS As Double, nSamp As Long
    Dim c As Long, r As Long, nSeed As Long
    
    'set seed value for Rnd2()
    nSeed = 17 'initial seed
    
    'set number of random samples to make
    nSamp = 45 '43 plus say, 2
    
    'set initial value of carry variable
    ix2 = nSeed
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'clear the worksheet
    sht.Cells.Cells.ClearContents
    
    'load sheet with set of samples
    For c = 1 To 5                'number of runs
        ix2 = nSeed + c           'change start value
        For r = 1 To nSamp        'number of samples
            nS = SimpleRnd43()    'get a sample
            sht.Cells(r, c) = nS  'write to sheet
        Next r
    Next c

    sht.Cells(1, 1).Select

End Sub

Function SimpleRnd43() As Double
   'simple Lehmer style LCNG to show repeat streams
   'produces one sequence of 42 unique values - then repeats entire sequence
   'start value decides only where the predictable sequence begins
   
   Dim r As Double
   
   'Note; Makes 42 unique values before sequence repeats
   'Modulus = 43: Multiplier = 5: Initial Seed = 17
   '43 is prime
   '5 is primitive root mod 43
   '17 is coprime to 43
   
   'ix2 cannot be 0.
   If ix2 = 0 Then
      ix2 = 17
   End If
   
   'calculate a new carry variable
   ix2 = (5 * ix2) Mod 43
   
   'make an output value
   r = ix2 / 43#
   SimpleRnd43 = r - Int(r)

End Function

Sub TestMSRnd()
    'makes two sets of single data using MS Rnd
    'the first 10 samples of Rnd() values
    'followed by values around sample 16777216
    'confirms sequence probably re-starts at M+1 = 16777217
    
    Dim sht As Worksheet, nS As Double
    Dim c As Long, r As Long, nMod As Long
    
    'note modulus
    nMod = 16777216
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    
    'clear the worksheet
    sht.Cells.Cells.ClearContents
    
    'load sheet with set of samples
    
        For r = 1 To nMod + 20   'number of samples
            nS = Rnd()            'get a sample
            Select Case r
                Case 1 To 10
                    sht.Cells(r, 1) = r
                    sht.Cells(r, 2) = nS
                Case (nMod - 4) To (nMod + 5)
                    sht.Cells(r - 16777211 + 10, 1) = r
                    sht.Cells(r - 16777211 + 10, 2) = nS
            End Select
        Next r
    
    sht.Cells(1, 1).Select

End Sub

References[edit]

  • Wichmann, Brian; Hill, David (1982), Algorithm AS183: An Efficient and Portable Pseudo-Random Number Generator, Journal of the Royal Statistical Society. Series C

See Also[edit]

External Links[edit]



A Pseudo Random Character Table

Summary[edit]

This code module is intended for MS Excel. It makes a pseudo random table of characters, integers and capitals in this case, on Sheet1. A new and different table is made each time the procedure is run.

The Table[edit]

  • Copy the code into a standard VBA module in Excel, and run the procedure MakePseudoRandomTable() to make a table. As shown, Sheet1 will be overwritten.
  • The output uses a monospaced font, Consolas, for the clearest layout and type. In addition to ensuring a neat layout vertically and horizontally, monospaced tables allow the reading of sequences on a diagonal, so greatly extend their usefulness.
  • Adjust the size of the table by changing the values nRows, and nCols in the code heading, and if necessary insert the name of the sheet to use. The code will add numbered row and column headings and will add these to each page that is displayed or printed.
  • If an exact number of columns and rows is needed, adjust the margins for the sheet, and perhaps the font size until the required result is obtained.
  • The proportion of integers to capitals is just 10/36, but is easily changed in code with a little effort.

The VBA Code Module[edit]

Option Explicit

Sub MakePseudoRandomTable()
    ' Makes a pseudo random table of integers and capitals
    ' using VBA internal function Rnd().
    
    'NOTES
    ' User should set narrow margins for best use of page.
    ' This will give about 47 rows by 35 cols
    ' Numbered headings are set to repeat on each printed page.
    ' Set number of rows and columns below.
    ' Integers to capitals ratio approx 10:26 = 0.385.
    ' Enter "0-127" in VBA Help for link to ASCI code numbers.
    
    Dim sht As Worksheet, sStr As String
    Dim nX As Integer, nAsc As Integer
    Dim nRows As Long, nCols As Long
    Dim nR As Long, nC As Long
       
    'set required table size and worksheet name here
    nRows = 100 'number of rows
    nCols = 100 'number of columns
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    sht.Activate
    
    'clear and format worksheet
    With sht.Columns
        .ClearContents
        .ClearFormats
        .HorizontalAlignment = xlCenter
        .Font.Name = "Consolas" 'monospaced
        .Font.Size = 12
        .ColumnWidth = 2
    End With
    
    Randomize Timer 'seed system timer
    For nR = 1 To nRows     'row loop
        For nC = 1 To nCols 'col loop
            'allow break commands
            DoEvents
            'choose integer between 1 and 36 (total number of characters)
            nX = Int((36 - 1 + 1) * Rnd + 1)
            'make asci numbers in a decided proportion
            'set nX<=18 And nX>=1 here for equal integers and capitals
            If nX <= 10 And nX >= 1 Then 'for 10:26
                nAsc = Int((57 - 48 + 1) * Rnd + 48) 'integers 48 to 57
            Else
                nAsc = Int((90 - 65 + 1) * Rnd + 65) 'capitals 65 to 90
            End If
            'convert asci number to string
            sStr = Chr(nAsc)
            'print single string character per cell
            sht.Cells(nR, nC).Value = sStr
        Next nC
    Next nR
        
    'add numbers to column headings
    For nC = 1 To nCols
        sht.Cells(1, nC) = nC
    Next nC
    'set size and orientation of column headings
    With sht.Rows(1)
        .Font.Size = 12
        .Orientation = 90 'vertical
    End With
    
    'add numbers to row headings
    For nR = 1 To nRows
        sht.Cells(nR, 1) = nR
    Next nR
    'set size of row headings
    With sht.Columns(1)
        .Font.Size = 12
    End With
    
    
    'print row and col headings on every page
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = "$A:$A"
    End With
    Application.PrintCommunication = True
    
    'select first cell
    sht.Cells(1, 1).Select

End Sub

See Also[edit]

External Links[edit]



Listing Prime Numbers

Summary[edit]

Figure 1:The Sieve of Eratosthenes. It is a methodical procedure for finding prime numbers, originally using a table. Notice that factors are eliminated only up to and including that which exceeds the square root of 120 (= 11).

This module implements the Sieve of Eratosthenes method for the listing of prime numbers. It is made to run in Microsoft Excel as a standard VBA module. It lists the prime numbers found between unity and some parameter integer value, on Sheet1 of the Workbook, and makes use of a message box for short listings.

  • Overflow is a problem for such procedures, but provided that the input parameter is kept within a few millions or so, overflow is unlikely.
  • The method although simple is quite slow, since even to test one single value, the entire sequence of multiples (2,3,5,7,...n) must be completed. Large values of input will take several minutes to complete. A faster approach is to test only those factors that are smaller than the square root of the input value; this modification is used in the procedure GetPrimeFactors().
  • Note that the the procedure will clear any contents of Sheet1 before each listing.
  • An animated GIF found in Wiki Commons is included in Figure 1 to illustrate the method.
  • GetPrimeFactors() and its utility DecMod() list the prime factors of a supplied integer. It is written for the decimal subtype, and so it handles inputs of up to 28 full digits, (assuming all nines). The time to complete varies greatly, depending on how many primes are found. For example, with an input of 23 nines the answer takes a very long time, but for 28 nines it takes just fifteen seconds or so. Other values like 20, 21, and 22 nines, and so on, are virtually instantaneous. The use of a string for input in the test procedure testGetPrimeFactors() is simply to prevent Excel from truncating the displayed input integer, and has no bearing on the method used; it is not string math here; just a decimal subtype loop.

Code Notes[edit]

The Code Module[edit]

Option Explicit

Sub testListPrimes()
    'Run this to list primes in range of
    'unity to some integer value
        
    Dim nNum As Long
    
    'set upper limit of range here
    'eg:1234567 gives 95360 primes from 2 to 1234547 in 3 minutes
    nNum = 1234567  
        
    'MsgBox ListPrimes(nNum)
    
    ListPrimes nNum

End Sub

Function ListPrimes(nInput As Long) As String
    'Lists primes in range unity to nInput
    'Output to Sheet1 and function name
    'Method: Sieve of Eratosthenes

    Dim arr() As Long, oSht As Worksheet, sOut As String
    Dim a As Long, b As Long, c As Long, s As Long
    Dim nRow As Long, nCol As Long
    
    'dimension array
    ReDim arr(1 To nInput)
    
    'set reference to Sheet1
    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    With oSht
        .Activate
        .Cells.ClearContents
    End With
    
    'fill work array with integers
    If nInput > 1 Then
        arr(1) = 0 'exception first element
        For a = 2 To nInput
           arr(a) = a
        Next a
    Else
        MsgBox "Needs parameter greater than unity - closing"
        Exit Function
    End If
    
    'Sieve of Eratosthenes
    'progressively eliminate prime multiples
    For b = 2 To nInput
        DoEvents 'yield
        If arr(b) <> 0 Then 'skip zeroed items
            'replace prime multiples with zero
            s = 2 * b
            Do Until s > nInput
                DoEvents 'yield
                arr(s) = 0
                s = s + b
            Loop
        End If
    Next b
    
    'Output of primes
    sOut = "Primes in range 1 to " & nInput & ":" & vbCrLf
    nRow = 1: nCol = 1
    For c = 2 To nInput
        If arr(c) <> 0 Then
            oSht.Cells(nRow, nCol) = c 'primes list to Sheet1
            nRow = nRow + 1
            If c <> nInput Then        'and accumulate a string
                sOut = sOut & c & ","
            Else
                sOut = sOut & c
            End If
        End If
    Next c
            
    ListPrimes = sOut

End Function

Sub testGetPrimeFactors()
    'Run this for prime factors of integer
    'Set integer as a string in sIn to avoid display truncation
    'Decimal subtype applies and limited to 28 full digits.
    
    Dim nIn, sIn As String, Reply, sOut As String, sT As String
    
    'set integer to factorise here, as a string
    sIn = "9999999999999999999999999999"  '28 nines takes 15 seconds
    nIn = CDec(sIn)
    
    sOut = GetPrimeFactors(nIn)

    MsgBox sOut & vbCrLf & _
           "Input digits length : " & Len(sIn)
           
    'optional inputbox allows copy of output
    Reply = InputBox("Factors of" & nIn, , sOut)

End Sub

Function DecMod(Dividend As Variant, Divisor As Variant) As Variant
    ' Declare two double precision variables
    
    Dim D1 As Variant, D2 As Variant

    D1 = CDec(Dividend)
    D2 = CDec(Divisor)
            
    'return remainder after division
    DecMod = D1 - (Int(D1 / D2) * D2)

End Function

Function GetPrimeFactors(ByVal nN As Variant) As String
    'Returns prime factors of nN in parameter
    'Maximum of 28 digits full digits for decimal subtype input.
    'Completion times vary greatly - faster for more primes
    '20,21,and 22 nines factorise immediately, 23 nines time excessive.
    '25 nines in 6 seconds. Maximum input takes 15 seconds for 28 nines.
    
    Dim nP As Variant, sAcc As String

    nP = CDec(nP)
    nP = 2
    nN = CDec(nN)
    sAcc = nN & " = "
    
    'test successive factors
    Do While nN >= nP * nP
       DoEvents
       If DecMod(nN, nP) = 0 Then
          sAcc = sAcc & nP & " * "
          nN = nN / nP '(divide by prime)
       Else
          nP = nP + 1
       End If
    Loop
    
    'output results
    GetPrimeFactors = sAcc & CStr(nN)
    
End Function

See Also[edit]



Big Number Arithmetic with Strings

Summary[edit]

  • This VBA module is intended for Microsoft Excel but can run with minor changes in any of the MS Office applications with a VBA editor.
  • The data types of VBA prevent big number calculations. That is to say, beyond twenty or thirty digits, and even then much care is needed to avoid overflow. Strings have few such restrictions, being limited in most cases to the size of the memory space of the application.
  • The code module below includes most of the basic arithmetic functions without any size restriction.
  • The work is not by this author, but credit should be given to Rebecca Gabriella's String Math Module notes at Big Integer Library. This author has made only cosmetic changes to the work, and added a test procedure to illustrate its use.

Code Notes[edit]

  • The module includes functions for the following: Addition, subtraction, multiplication, and division, all using integer strings. Also included are conversion functions to restore base10 from some other base, and to produce a new base from some existing base10 input. Other support functions such as RealMod() are also included.
  • No output code to the sheet has been provided. Owing to Excel's habit of truncating numbers, even if they are strings, users who want to use the worksheet should concatenate an apostrophe before the display string to prevent this happening. The apostrophe will not be displayed. It is unclear how else this device affects the subsequent use of the numbers.
  • A remainder after division is produced. It can be found as sLastRemainder, and is public.
  • Users who install code in MS Access should change the Option Compare Text to Option Compare DataBase. The former is intended for MS Excel.

The VBA String Math Module[edit]

Option Explicit
Option Compare Text 'Database for Access
'--------------------------------------------------------------------------------------------------------------
'https://cosxoverx.livejournal.com/47220.html
'Credit to Rebecca Gabriella's String Math Module (Big Integer Library) for VBA (Visual Basic for Applications)
' Minor edits made with comments and other.
'--------------------------------------------------------------------------------------------------------------

Public Type PartialDivideInfo
    Quotient As Integer
    Subtrahend As String
    Remainder As String
End Type

Public sLastRemainder As String
Private Const Alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Private Sub TestMultAndDiv()
    'Run this to test multiplication and division with integer strings
    'Open immediate window in View or with ctrl-g to see results
    
    Dim sP1 As String, sP2 As String, sRes1 As String, sRes2 As String
    
    sP1 = "6864797660130609714981900799081393217269" & _
          "4353001433054093944634591855431833976560" & _
          "5212255964066145455497729631139148085803" & _
          "7121987999716643812574028291115057151"         '157 digits and prime
    sP2 = "162259276829213363391578010288127"             '33 digits and also prime

    'multiply these two as integer strings
    sRes1 = Multiply(sP1, sP2)
    Debug.Print sP1
    Debug.Print "Length of 1st number : " & Len(sP1)
    Debug.Print sP2
    Debug.Print "Length of 2nd number : " & Len(sP2)
    Debug.Print "Product : " & sRes1
    Debug.Print "Length of product : " & Len(sRes1)
    Debug.Print " "

    'then divide the product by sP1 obtains sP2 again
    sRes2 = Divide(sRes1, sP1)
    Debug.Print sRes1
    Debug.Print "Length of 1st number : " & Len(sRes1)
    Debug.Print sP1
    Debug.Print "Length of 2nd number : " & Len(sP1)
    Debug.Print "Integer Quotient : " & sRes2
    Debug.Print "Length of quotient : " & Len(sRes2)
    Debug.Print "Remainder after integer division : " & sLastRemainder
    Debug.Print " "

    'Notes:
    'Clear immediate window with ctrl-g, then ctrl-a, then delete
    'If sending long integer strings to the worksheet, prefix with apostrophe before output
    'or it will be truncated by Excel.  Needs consideration also on pickup from sheet.
    'Alternatively use a textbox in a userform for error free display.  Ctrl-C to copy out.

End Sub

Private Function Compare(ByVal sA As String, ByVal sB As String) As Integer
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns an integer that represents one of three states
    'sA > sB returns 1, sA < sB returns -1, and sA = sB returns 0
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim i As Integer, iA As Integer, iB As Integer
    
    'handle any early exits on basis of signs
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    If bAN And bBN Then
        bRN = True
    ElseIf bBN Then
        Compare = 1
        Exit Function
    ElseIf bAN Then
        Compare = -1
        Exit Function
    Else
        bRN = False
    End If
    
    'remove any leading zeros
    Do While Len(sA) > 1 And Left(sA, 1) = "0"
        sA = Mid(sA, 2) 'starting at pos 2
    Loop
    Do While Len(sB) > 1 And Left(sB, 1) = "0"
        sB = Mid(sB, 2) 'starting at pos 2
    Loop
    
    'then decide size first on basis of length
    If Len(sA) < Len(sB) Then
        Compare = -1
    ElseIf Len(sA) > Len(sB) Then
        Compare = 1
    Else 'unless they are the same length
        Compare = 0
        'then check each digit by digit
        For i = 1 To Len(sA)
            iA = CInt(Mid(sA, i, 1))
            iB = CInt(Mid(sB, i, 1))
            If iA < iB Then
                Compare = -1
                Exit For
            ElseIf iA > iB Then
                Compare = 1
                Exit For
            Else 'defaults zero
            End If
        Next i
    End If
    
    'decide about any negative signs
    If bRN Then
        Compare = -Compare
    End If

End Function

Public Function Add(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sum of sA and sB as string integer in Add()
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim iA As Integer, iB As Integer, iCarry As Integer
       
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Add()"
        Exit Function
    End If
        
    'handle some negative values with Subtract()
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    If bAN And bBN Then 'both negative
        bRN = True      'set output reminder
    ElseIf bBN Then     'use subtraction
        Add = Subtract(sA, sB)
        Exit Function
    ElseIf bAN Then     'use subtraction
        Add = Subtract(sB, sA)
        Exit Function
    Else
        bRN = False
    End If
    
    'add column by column
    iA = Len(sA)
    iB = Len(sB)
    iCarry = 0
    Add = ""
    Do While iA > 0 And iB > 0
        iCarry = iCarry + CInt(Mid(sA, iA, 1)) + CInt(Mid(sB, iB, 1))
        Add = CStr(iCarry Mod 10) + Add
        iCarry = iCarry \ 10
        iA = iA - 1
        iB = iB - 1
    Loop
    
    'Assuming param sA is longer
    Do While iA > 0
        iCarry = iCarry + CInt(Mid(sA, iA, 1))
        Add = CStr(iCarry Mod 10) + Add
        iCarry = iCarry \ 10
        iA = iA - 1
    Loop
    'Assuming param sB is longer
    Do While iB > 0
        iCarry = iCarry + CInt(Mid(sB, iB, 1))
        Add = CStr(iCarry Mod 10) + Add
        iCarry = iCarry \ 10
        iB = iB - 1
    Loop
    Add = CStr(iCarry) + Add
    
    'remove any leading zeros
    Do While Len(Add) > 1 And Left(Add, 1) = "0"
        Add = Mid(Add, 2)
    Loop
    
    'decide about any negative signs
    If Add <> "0" And bRN Then
        Add = "-" + Add
    End If

End Function

Private Function RealMod(ByVal iA As Integer, ByVal iB As Integer) As Integer
    'Returns iA mod iB in RealMod() as an integer. Good for small values.
    'Normally Mod takes on the sign of iA but here
    'negative values are increased by iB until result is positive.
    'Credit to Rebecca Gabriella's String Math Module with added edits.
    'https://cosxoverx.livejournal.com/47220.html
        
    If iB = 0 Then
        MsgBox "Divide by zero in RealMod()"
        Exit Function
    End If
    
    If iA Mod iB = 0 Then
        RealMod = 0
    ElseIf iA < 0 Then
        RealMod = iB + iA Mod iB 'increase till pos
    Else
        RealMod = iA Mod iB
    End If

End Function

Private Function RealDiv(ByVal iA As Integer, ByVal iB As Integer) As Integer
    'Returns integer division iA divided by iB in RealDiv().Good for small values.
    'Credit to Rebecca Gabriella's String Math Module with added edits.
    'https://cosxoverx.livejournal.com/47220.html
    
    If iB = 0 Then
        MsgBox "Divide by zero in RealDiv()"
        Exit Function
    End If
    
    If iA Mod iB = 0 Then
        RealDiv = iA \ iB
    ElseIf iA < 0 Then
        RealDiv = iA \ iB - 1 'round down
    Else
        RealDiv = iA \ iB
    End If

End Function

Public Function Subtract(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sA minus sB as string integer in Subtract()
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim iA As Integer, iB As Integer, iComp As Integer
    
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Subtract()"
        Exit Function
    End If
        
    'handle some negative values with Add()
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    If bAN And bBN Then
        bRN = True
    ElseIf bBN Then
        Subtract = Add(sA, sB)
        Exit Function
    ElseIf bAN Then
        Subtract = "-" + Add(sA, sB)
        Exit Function
    Else
        bRN = False
    End If
    
    'get biggest value into variable sA
    iComp = Compare(sA, sB)
    If iComp = 0 Then     'parameters equal in size
        Subtract = "0"
        Exit Function
    ElseIf iComp < 0 Then 'sA < sB
        Subtract = sA     'so swop sA and sB
        sA = sB           'to ensure sA >= sB
        sB = Subtract
        bRN = Not bRN     'and reverse output sign
    End If
    iA = Len(sA)          'recheck lengths
    iB = Len(sB)
    iComp = 0
    Subtract = ""
        
    'subtract column by column
    Do While iA > 0 And iB > 0
        iComp = iComp + CInt(Mid(sA, iA, 1)) - CInt(Mid(sB, iB, 1))
        Subtract = CStr(RealMod(iComp, 10)) + Subtract
        iComp = RealDiv(iComp, 10)
        iA = iA - 1
        iB = iB - 1
    Loop
    'then assuming param sA is longer
    Do While iA > 0
        iComp = iComp + CInt(Mid(sA, iA, 1))
        Subtract = CStr(RealMod(iComp, 10)) + Subtract
        iComp = RealDiv(iComp, 10)
        iA = iA - 1
    Loop
    
    'remove any leading zeros from result
    Do While Len(Subtract) > 1 And Left(Subtract, 1) = "0"
        Subtract = Mid(Subtract, 2)
    Loop
    
    'decide about any negative signs
    If Subtract <> "0" And bRN Then
        Subtract = "-" + Subtract
    End If

End Function

Public Function Multiply(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sA times sB as string integer in Multiply()
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
    Dim m() As Long, iCarry As Long
    Dim iAL As Integer, iBL As Integer, iA As Integer, iB As Integer
        
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Multiply()"
        Exit Function
    End If
        
    'handle any negative signs
    bAN = (Left(sA, 1) = "-")
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2)
    If bBN Then sB = Mid(sB, 2)
    bRN = (bAN <> bBN)
    iAL = Len(sA)
    iBL = Len(sB)
    
    'perform long multiplication without carry in notional columns
    ReDim m(1 To (iAL + iBL - 1)) 'expected length of product
    For iA = 1 To iAL
        For iB = 1 To iBL
            m(iA + iB - 1) = m(iA + iB - 1) + CLng(Mid(sA, iAL - iA + 1, 1)) * CLng(Mid(sB, iBL - iB + 1, 1))
        Next iB
    Next iA
    iCarry = 0
    Multiply = ""
    
    'add up column results with carry
    For iA = 1 To iAL + iBL - 1
        iCarry = iCarry + m(iA)
        Multiply = CStr(iCarry Mod 10) + Multiply
        iCarry = iCarry \ 10
    Next iA
    Multiply = CStr(iCarry) + Multiply
    
    'remove any leading zeros
    Do While Len(Multiply) > 1 And Left(Multiply, 1) = "0"
        Multiply = Mid(Multiply, 2)
    Loop
    
    'decide about any negative signs
    If Multiply <> "0" And bRN Then
        Multiply = "-" + Multiply
    End If

End Function

Public Function PartialDivide(ByVal sA As String, ByVal sB As String) As PartialDivideInfo
    'Called only by Divide() to assist in fitting trials for long division
    'All of Quotient, Subtrahend, and Remainder are returned as elements of type PartialDivideInfo
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
        
    For PartialDivide.Quotient = 9 To 1 Step -1                                'propose a divisor to fit
        PartialDivide.Subtrahend = Multiply(sB, CStr(PartialDivide.Quotient))  'test by multiplying it out
        If Compare(PartialDivide.Subtrahend, sA) <= 0 Then                     'best fit found
            PartialDivide.Remainder = Subtract(sA, PartialDivide.Subtrahend)   'get remainder
            Exit Function                                                      'exit with best fit details
        End If
    Next PartialDivide.Quotient
    
    'no fit found, divisor too big
    PartialDivide.Quotient = 0
    PartialDivide.Subtrahend = "0"
    PartialDivide.Remainder = sA

End Function

Public Function Divide(ByVal sA As String, ByVal sB As String) As String
    'Parameters are string integers of any length, for example "-345...", "973..."
    'Returns sA divided by sB as string integer in Divide()
    'The remainder is available as sLastRemainder at Module level
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
    
    Dim bAN  As Boolean, bBN As Boolean, bRN As Boolean
    Dim iC As Integer
    Dim s As String
    Dim d As PartialDivideInfo
    
    'test for empty parameters
    If Len(sA) = 0 Or Len(sB) = 0 Then
        MsgBox "Empty parameter in Divide()"
        Exit Function
    End If
    
    bAN = (Left(sA, 1) = "-") 'true for neg
    bBN = (Left(sB, 1) = "-")
    If bAN Then sA = Mid(sA, 2) 'take two charas if neg
    If bBN Then sB = Mid(sB, 2)
    bRN = (bAN <> bBN)
    If Compare(sB, "0") = 0 Then
        Err.Raise 11
        Exit Function
    ElseIf Compare(sA, "0") = 0 Then
        Divide = "0"
        sLastRemainder = "0"
        Exit Function
    End If
    iC = Compare(sA, sB)
    If iC < 0 Then
        Divide = "0"
        sLastRemainder = sA
        Exit Function
    ElseIf iC = 0 Then
        If bRN Then
            Divide = "-1"
        Else
            Divide = "1"
        End If
        sLastRemainder = "0"
        Exit Function
    End If
    Divide = ""
    s = ""
    
    'Long division method
    For iC = 1 To Len(sA)
        'take increasing number of digits
        s = s + Mid(sA, iC, 1)
        d = PartialDivide(s, sB) 'find best fit
        Divide = Divide + CStr(d.Quotient)
        s = d.Remainder
    Next iC
    
    'remove any leading zeros
    Do While Len(Divide) > 1 And Left(Divide, 1) = "0"
        Divide = Mid(Divide, 2)
    Loop
    
    'decide about the signs
    If Divide <> "0" And bRN Then
        Divide = "-" + Divide
    End If
    
    sLastRemainder = s 'string integer remainder

End Function

Public Function LastModulus() As String
    LastModulus = sLastRemainder
End Function

Public Function Modulus(ByVal sA As String, ByVal sB As String) As String
    Divide sA, sB
    Modulus = sLastRemainder
End Function

Public Function BigIntFromString(ByVal sIn As String, ByVal iBaseIn As Integer) As String
    'Returns base10 integer string from sIn of different base (iBaseIn).
    'Example for sIn = "1A" and iBaseIn = 16, returns the base10 result 26.
    'Credit to Rebecca Gabriella's String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
            
    Dim bRN As Boolean
    Dim sBS As String
    Dim iP As Integer, iV As Integer
    
    'test for empty parameters
    If Len(sIn) = 0 Or iBaseIn = 0 Then
        MsgBox "Bad parameter in BigIntFromString()"
        Exit Function
    End If
        
    'handle negative signs
    If Left(sIn, 1) = "-" Then
        bRN = True
        sIn = Mid(sIn, 2)
    Else
        bRN = False
    End If
    sBS = CStr(iBaseIn)
    
    BigIntFromString = "0"
    For iP = 1 To Len(sIn)
        'use constant list position and base for conversion
        iV = InStr(Alphabet, UCase(Mid(sIn, iP, 1)))
        If iV > 0 Then 'accumulate
            BigIntFromString = Multiply(BigIntFromString, sBS)
            BigIntFromString = Add(BigIntFromString, CStr(iV - 1))
        End If
    Next iP
    
    'decide on any negative signs
    If bRN Then
        BigIntFromString = "-" + BigIntFromString
    End If

End Function

Public Function BigIntToString(ByVal sIn As String, ByVal iBaseOut As Integer) As String
    'Returns integer string of specified iBaseOut (iBaseOut) from base10 (sIn) integer string.
    'Example for sIn = "26" and iBaseOut = 16, returns the output "1A".
    'Credit to Rebecca Gabriella'sIn String Math Module with added edits
    'https://cosxoverx.livejournal.com/47220.html
            
    Dim bRN As Boolean
    Dim sB As String
    Dim iV As Integer
    
    'test for empty parameters
    If Len(sIn) = 0 Or iBaseOut = 0 Then
        MsgBox "Bad parameter in BigIntToString()"
        Exit Function
    End If
    
    'handle negative signs
    If Left(sIn, 1) = "-" Then
        bRN = True
        sIn = Mid(sIn, 2)
    Else
        bRN = False
    End If
    sB = CStr(iBaseOut)
    
    BigIntToString = ""
    Do While Compare(sIn, "0") > 0
        sIn = Divide(sIn, sB)
        iV = CInt(LastModulus())
        'locates appropriate alphabet character
        BigIntToString = Mid(Alphabet, iV + 1, 1) + BigIntToString
    Loop
    
    'decide on any negative signs
    If BigIntToString = "" Then
        BigIntToString = "0"
    ElseIf BigIntToString <> "0" And bRN Then
        BigIntToString = "-" + BigIntToString
    End If

End Function

Added Big Math Fuctions[edit]

  • Factorial() makes use of Multiply() and other integer math functions of the main module. It is of course fairly slow but is not otherwise limited in any practical way. The code has been arbitrarily limited to calculating values up to 1000!, but this can be adjusted by the user. DoEvents is important here, since it allows breaking the run if an unwise attempt is made. Reciprocal factorials and negative factorials are not handled here.
  • IntStrByExp() raises integer strings to an exponent. Again, negative exponents cannot yet be handled in this procedure, though the number to raise can take a negative value.
Sub testFactorial()
   'Run this to test factorial
      
   Dim sIn As Integer, sOut As String
   
   sIn = "400"
   sOut = Factorial(sIn)
   
   'output Immediate Window
   Debug.Print sIn & "!" & vbCrLf & _
               sOut & vbCrLf & _
               Len(sOut) & " digits" & vbCrLf
   
   'output message box - short output
   'MsgBox sIn & "!" & vbcrlf & _
           sOut & vbCrLf & _
           Len(sOut) &  " digits" & vbCrLf

End Sub

Function Factorial(ByVal sA As String) As String
    'Returns integer string factorial for integer string parameter sA
    '2000! in 30 secs (5736 digits); 1000! in six seconds (2568 digits)
    '400! in one second (869 digits);100! pdq (158 digits).
    'Arbitrarily set max sA = "1000"
    
    Dim iC As Integer
        
    'avoid excessively long runs
    If CInt(sA) >= 1000 Then
        MsgBox "Run time too long - closing."
        Factorial = "Error - Run time too long"
        Exit Function
    End If
        
    iC = CInt(sA)
    Factorial = "1"
    
    'run factorial loop
    Do Until iC <= 0
        DoEvents 'permits break key use
        Factorial = Multiply(Factorial, iC)
        iC = iC - 1
    Loop

End Function

Sub testIntStrByExp()
   'Run this to test IntStrByExp
      
   Dim sIn As String, sOut As String, iExp As Integer, bA As Boolean
   Dim nL As Integer
   
   
   sIn = "-123456789123456789"
   iExp = 7
   
   sOut = IntStrByExp(sIn, iExp)
   nL = Len(sOut)
   If Left(sOut, 1) = "-" Then
   nL = nL - 1
   End If
   
   'output Immediate Window
   Debug.Print sIn & "^" & iExp & " equals" & vbCrLf & _
               sOut & vbCrLf & _
               nL & " digits out" & vbCrLf
   
   'output message box - short output
   MsgBox sIn & "^" & iExp & " equals" & vbCrLf & _
               sOut & vbCrLf & _
               nL & " digits out" & vbCrLf

End Sub

Function IntStrByExp(ByVal sA As String, ByVal iExp As Integer) As String
    'Returns integer string raised to exponent iExp as integer string
    'Assumes posiive exponent, and pos or neg string integer
    
    Dim bA As Boolean, bR As Boolean
    
    'check parameter
    If iExp < 0 Then
        MsgBox "Cannot handle negative powers yet"
        Exit Function
    End If
    
    'handle any negative signs
    bA = (Left(sA, 1) = "-")
    If bA Then sA = Mid(sA, 2) Else sA = Mid(sA, 1)
    If bA And RealMod(iExp, 2) <> 0 Then bR = True
    
    'run multiplication loop
    IntStrByExp = "1"
    Do Until iExp <= 0
        DoEvents 'permits break key use
        IntStrByExp = Multiply(IntStrByExp, sA)
        iExp = iExp - 1
    Loop

    'remove any leading zeros
    Do While Len(IntStrByExp) > 1 And Left(IntStrByExp, 1) = "0"
        IntStrByExp = Mid(IntStrByExp, 2)
    Loop
    
    'decide on any signs
    If IntStrByExp <> "0" And bR Then
       IntStrByExp = "-" & IntStrByExp
    End If

End Function

See Also[edit]

External Links[edit]



Excel Sheet True Used Range

Summary[edit]

  • This code listing is for Excel. The procedure GetUsedRange returns the true used range of the Worksheet in the function name. An example is also given below of its use in the procedure WorkRangeInArray. It can typically be used to find the next writing position on a worksheet, but in any case returns all of the cell limits on each run.
  • Reports on various internet sites describe problems with the built-in UsedRange function. The problem types, apart from errors of understanding, seem to be divided between issues concerning the number of cells scrolled and errors in reporting the used range itself. This author has been unable to reproduce errors in reporting the UsedRange but requests inputs from interested parties. Readers with a clear demonstration of the UsedRange problem might care to advi