Visual Basic for Applications/Print version
| This is the print version of Visual Basic for Applications You won't see this message or any elements not part of the book's content when you print or preview this page. |
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.
Character 1D Arrays
SummaryEdit
- 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 codeEdit
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 ModuleEdit
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 AlsoEdit
External LinksEdit
Array Data To Immediate Window
SummaryEdit
This VBA code module allows the listing of arrays in the immediate window. So that the user can see examples of its use, 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. Clearly, mixed data varies in length and in its number of decimal points. This module displays the array neatly taking account of the variations that might otherwise disrupt the layout. It can decimal point align the data or not, according to internal options.
Code NotesEdit
- 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.
- Note that the user might add a procedure to export large values of sOut, the formatted string, to the clipboard. Procedures exist elsewhere in this series that will accomplish this.
The VBA ModuleEdit
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.
UpdatesEdit
- 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 AlsoEdit
Array Data To WorkSheet (1D or 2D)
SummaryEdit
This MS Excel VBA code listing transfers data from a one or two dimensional array to a worksheet.
Code NotesEdit
- 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 ModuleEdit
- 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 AlsoEdit
Array Output Transfers
SummaryEdit
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 NotesEdit
- 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 ModuleEdit
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 AlsoEdit
Charts from Arrays
SummaryEdit
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 CodeEdit
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
SummaryEdit
VBA Code ListingsEdit
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
SummaryEdit
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 MethodEdit
- 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 MethodEdit
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 MethodEdit
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 MethodEdit
The code below was tested on an Office 2010 version of Excel, 32 bit system, and worked well. Since that time, with 64 bit 2019 Excel, the code will not work in its current state, but needs further changes to the declarations for 64 bit use.
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 AlsoEdit
- 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
SummaryEdit
- This VBA code module runs the sixteenth century Vigenere cipher. It is used to conceal the contents of a message, and was probably used in short term military messaging . The method is an early example of an attempt to disguise the natural frequency of the language used in communication. 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 does not include spaces, since these tend to assist in code breaking, and although it could have been further restricted to just capital letters, it was decided that adding integers would make it more useful.
- The code is intended for Microsoft Excel, but is easily adapted to work in other MS Office products that run VBA. For example, to run it in MS Word, the results will still display in the message box, but it will be necessary to comment-out all lines, (put an apostrophe before each), of the '''output to sheet 1'' and ''make columns fit sections''.
- Figure 1 shows the Vigenere table without integers or other characters. Figure 2, the basis for the coding, shows a similar table that includes integers and capitals, and no other characters.
- 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 very short key "BULGE" was extended to "BULGEBUL" to cover the eight characters of the message. Clearly, the extension of the key in this way avoids any fixed relationship in the encryption, especially when more complex keys are used.
- 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 CodeEdit
- 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, while 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 numbers within range.
- There is some latitude for improvement of the code. For example, the set could be further extended, and the key could be tested to avoid some of the flaws that are characteristic of this cipher. At present, the user must interpret the position for spaces in the decrypted results; this helps to better conceal the use of the frequently used space character. So, extend the set only at the risk of worsened performance. As mentioned before, a user form could be made to replace direct entry.
- Because repeat patterns can develop, some care is needed in coding. 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 hash procedures elsewhere in this series; (use base64 output). 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 TableEdit
|
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 in places, so they are not fully interchangeable.
A Worked ExampleEdit
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 ModuleEdit
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.
Corrections:
6 April 2020; corrected a note in SubMod36(); does not affect operation.
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-36
'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 36
'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 35
'Returns negative results as positive by adding 36
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 AlsoEdit
Error Handling
SummaryEdit
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 CodeEdit
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 AlsoEdit
External LinksEdit
File and Folder Dialogs
SummaryEdit
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 ModuleEdit
This code was tested as working for Excel 2010 32 bit systems, but does not work for Excel 2019 64 bit. It is understood that the declarations no longer conform in their present format. Some difficulty has been encountered in finding a universal layout.
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 AlsoEdit
External LinksEdit
- 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
SummaryEdit
- 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 CodeEdit
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
SummaryEdit
- 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 NotesEdit
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 ModuleEdit
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 AlsoEdit
External LinksEdit
Font Utilities
SummaryEdit
- 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 TestsEdit
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 NotesEdit
Code ModuleEdit
RevisionsEdit
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 AlsoEdit
External LinksEdit
The Elusive Button
SummaryEdit
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 NotesEdit
- 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 ModuleEdit
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 ModuleEdit
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 ModificationsEdit
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 AlsoEdit
String Hashing in VBA
SummaryEdit
- 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 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 ListingsEdit
Notes on the CodeEdit
IMPORTANT. It was found that the hash routines errored in a Windows 10, 64 bit Office setup. However, subsequent checking revealed the solution. The Windows platform must have intalled the Net Framework 3.5 (includes .Net 2 and .Net 3), this older version, and not only the Net Framework 4.8 Advanced Services that was enabled in Turn Windows Features on and off. When it was selected there, the routines worked perfectly.
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.
If your data is in ANSI, you will get different results between Excel/ACCESS and SQL Server when using T-SQL HASHBYTES() function for characters code over 128. To solve those differences use StrConv() instead of .GetBytes_4()
'dont use for ANSI
Set oT = CreateObject("System.Text.UTF8Encoding")
TextToHash = oT.GetBytes_4(sIn)
'for ANSI data use StrConv instead
TextToHash = StrConv(sIn, vbFromUnicode)
Option Explicit
Sub Test()
'run this to test md5, sha1, sha2/256, sha384, sha2/512 with salt, or sha2/512
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
'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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
'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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
'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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
'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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
'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.
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
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
'Check that Net Framework 3.5 (includes .Net 2 and .Net 3 is installed in windows
'and not just Net Advanced Services
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 AlsoEdit
- 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
SummaryEdit
- 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 ListingsEdit
IMPORTANT. It was found that the hash routines errored in a Windows 10, 64 bit Office setup. However, subsequent checking revealed the solution. The Windows platform must have intalled the Net Framework 3.5 (includes .Net 2 and .Net 3), this older version, and not only the Net Framework 4.8 Advanced Services that was enabled in Turn Windows Features on and off. When it was selected there, the routines worked perfectly.
ModificationsEdit
- Added default code for transfer of results to the clipboard, 11 Sep 2020
- Set file selection dialog to open with all-file types to be listed, 25 July 2019
- Added file selection dialog, and file size limits, 17 Jun 2019
Using Built-in Windows Functions in VBAEdit
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. A procedure has been included to overwrite the clipboard with the results: If this is not inteded then comment the line out in the top procedure.
Option Explicit
Public sFPath As String, sH As String
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 Microsoft Scripting Runtime
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
Dim b64 As Boolean, bOK As Boolean, bOK2 as Boolean
Dim 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 these two lines to overwrite the clipboard with the results
bOK2 = CopyToClip(sH)
If bOK2 = True Then MsgBox ("The result is on the clipboard.")
'decomment this line to append the hash to a file (after setting its path)
'AppendHashToFile
'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
Private Sub AppendHashToFile()
Dim sFPath2 As String, fso As FileSystemObject, ts As TextStream
Dim sContents As String, sNewContents As String
sFPath2 = "C:\Users\Your Folder\Documents\test.txt" 'eg.
Set fso = New FileSystemObject
If Not Dir(sFPath2) = vbNullString Then
'docs.microsoft.com/office/vba/language/reference/user-interface-help/opentextfile-method
'devblogs.microsoft.com/scripting/how-can-i-add-a-line-to-the-top-of-a-text-file/
Set ts = fso.OpenTextFile(sFPath2, ForReading)
sContents = ts.ReadAll: ts.Close
End If
sNewContents = sH & vbTab & sFPath & vbTab & Now & vbNewLine & sContents
sNewContents = Left(sNewContents, Len(sNewContents) - 2)
Set ts = fso.OpenTextFile(sFPath2, ForWriting, True)
ts.WriteLine sNewContents: ts.Close
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
Function CopyToClip(sIn As String) As Boolean
'passes the parameter string to the clipboard
'set reference to Microsoft Forms 2.0 Object Library (by browsing for FM20.DLL).
'If ref not listed, inserting user form will list it.
'Clipboard cleared when launch application closes.
'Make sure that Net Framework 3.5 (includes .Net 2 and .Net 3) is installed and enabled
'and not only the Net Framework 4.8 Advanced Services
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
See AlsoEdit
- 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 LinksEdit
- 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
SummaryEdit
- 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 ModulesEdit
File:Folder Options.png
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.
IMPORTANT. It was found that the hash routines errored in a Windows 10, 64 bit Office setup. However, subsequent checking revealed the solution. The Windows platform must have intalled the Net Framework 3.5 (includes .Net 2 and .Net 3), this older version, and not only the Net Framework 4.8 Advanced Services that was enabled in Turn Windows Features on and off. When it was selected there, the routines worked perfectly.
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 AppEdit
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 hashesEdit
- 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 FoldersEdit
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 NotesEdit
- Code modified 17 Oct 20, replaced the API version of folder selection with one that is independent of 32 or 64 bit working
- 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 ModuleEdit
Private Sub Workbook_Open()
'displays userform for
'options and running
Load UserForm1
UserForm1.Show
End Sub
The Userform1 ModuleEdit
Option Explicit
Option Compare Binary 'default,important
Private Sub CommandButton1_Click()
'opens and returns a FOLDER path
'using the BrowseFolderExplorer() dialog
'Used to access the top folder for hashing
'select folder
sTargetPath = BrowseFolderExplorer("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 Module1Edit
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
Function BrowseFolderExplorer(Optional DialogTitle As String, _
Optional ViewType As MsoFileDialogView = _
MsoFileDialogView.msoFileDialogViewSmallIcons, _
Optional InitialDirectory As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BrowseFolderExplorer
' This provides an Explorer-like Folder Open dialog.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'fDialog.InitialView = ViewType
With fDialog
If Dir(InitialDirectory, vbDirectory) <> vbNullString Then
.InitialFileName = InitialDirectory
Else
.InitialFileName = CurDir
End If
.Title = DialogTitle
If .Show = True Then
' user picked a folder
BrowseFolderExplorer = .SelectedItems(1)
Else
' user cancelled
BrowseFolderExplorer = vbNullString
End If
End With
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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
'The windows platform must have intalled the '''Net Framework 3.5 (includes .Net 2 and .Net 3)'''
'and not only the '''Net Framework 4.8 Advanced Services'''
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 AlsoEdit
- File Hashing in VBA: Contains code for single file hashing, and in particular, notes on applications to hash large files.*
- String Hashing in VBA: Code for the hashing of strings.
External LinksEdit
Running the FCIV Utility from VBA
SummaryEdit
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 ListingsEdit
FCIV Hash Run at the Command LineEdit
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 VBAEdit
The Shell function in VBA has no Wait feature, so the Shell line is best as the last. That is to say, even while the Shell command is still processing, it will pass control to the next line in the procedure that contains it before it is done; so the procedure's end will otherwise interrupt the Shell function and the process is likely to fail. The quotes are also a little different in this case from the usual VBA expectation. Note that all of the paths have been enclosed in two sets of double quotes and that the entire command line itself is then enclosed in one additional 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, and all of its subfolders, 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 AlsoEdit
- File Checksum Integrity Verifier (FCIV)_Examples  : Detailed examples of how to run the fciv utility, from both the command line and VBA. There are additional notes for the use of the command prompt screen.
External LinksEdit
- Availability and description of the File Checksum Integrity Verifier utility  : The Microsoft page on fciv, though a bit sparse in description.
- 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.
Use Log Files from VBA
SummaryEdit
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 LogsEdit
- 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 LogsEdit
- 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 CodeEdit
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 vR
'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
SummaryEdit
This code block contains a message box function for YES, NO or CANCEL.
VBA CodeEdit
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 AlsoEdit
External LinksEdit
Input Boxes
SummaryEdit
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 CodeEdit
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 AlsoEdit
External LinksEdit
Pseudo Random Repeated Substrings
SummaryEdit
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() FunctionEdit
- 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 (in function name) and number of repeats (in nSS)
'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
SummaryEdit
- A pseudo-random number generator (PRNG), if run for long enough, generates a characteristic sequence that is based on its algorithm. This sequence repeats forever 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 16,777,216 values between zero and unity, then start again at the beginning, making a repeating sequence with a cycle length of 16,777,216. The only option for the user is to choose the starting point within that one sequence. This is done by choosing a start value or seed. In the case of Rnd(), the start value is chosen in two 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 that one long sequence will be used. Linear Congruential Generators (LCG), the type used by Microsoft's Rnd() function are described in detail at Linear congruential generator.
- The maximum cycle length for a single stage LCG is equal to its modulus. For combined generators, the maximum cycle length is equal to the least common multiple of the cycle lengths of the individual generators. A well-designed generator will have the maximum cycle length and consist only of unique values throughout its sequence, but not all generators are well-designed. The above link describes the design values required to make an LCG with a maximum cycle length over all of its starting values.
- The code module below contains the Wichmann-Hill (1982) CLCG (combined LCG) 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 only to beginners.
- Long-cycle generators are awkward to study in Excel. The cycles of both Microsoft's Rnd() and the user function RndX() are much too long to write a complete cycle 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() algorithmEdit
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 length of:
Cycle length = least_common_multiple(30268, 30306, 30322) = 30268 * 30306 * 30322 / 4 = 6,953,607,871,644
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 LCG 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.
|
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 PRNGsEdit
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
ReferencesEdit
- Wichmann, Brian; Hill, David (1982), Algorithm AS183: An Efficient and Portable Pseudo-Random Number Generator, Journal of the Royal Statistical Society. Series C
See AlsoEdit
- Wichmann-Hill CLCG: A Wikipedia article on the specific combined linear congruential generator in question.
- Linear congruential generator: A good Wikipedia description of the conditions for a full cycle.
External LinksEdit
- How Visual Basic Generates Pseudo-Random Numbers for the RND Function: Microsoft kb231847 knowledge base item
A Pseudo Random Character Table
SummaryEdit
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 TableEdit
- 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 ModuleEdit
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 AlsoEdit
External LinksEdit
Listing Prime Numbers
SummaryEdit
.
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. There is one peculiarity noted; 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 NotesEdit
The Code ModuleEdit
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 AlsoEdit
Big Number Arithmetic with Strings
SummaryEdit
- 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 NotesEdit
- 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 ModuleEdit
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 FuctionsEdit
- 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