Opening the book…
 | 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
Summary
- This VBA code module is intended for any Microsoft Office application that supports VBA.
- It allows strings to be loaded into one-dimensional arrays one character per element, and to join such array characters into single strings again.
- The module is useful in splitting the characters of a single word ,something that the Split method cannot handle.
Notes on the code
Copy all of the procedures below into a VBA standard module, save the workbook as a xlsm type, then run the top procedure to show that the process is accurate.
The VBA Code Module
Sub testStrTo1DArr()
' run this to test array string load
' and array to string remake procedures
Dim vR As Variant, vE As Variant
Dim sStr As String, bOK As Boolean, sOut As String
sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
'split string into array elements
bOK = StrTo1DArr(sStr, vR, False)
If bOK = True Then
'optional array transfer
vE = vR
'remake string from array
sOut = Arr1DToStr(vE)
'show that output = input
MsgBox sStr & vbCrLf & sOut
Else
Exit Sub
End If
End Sub
Function StrTo1DArr(ByVal sIn As String, vRet As Variant, _
Optional ByVal bLB1 As Boolean = True) As Boolean
' Loads string characters into 1D array (vRet). One per element.
' Optional choice of lower bound. bLB1 = True for one-based (default),
' else bLB1 = False for zero-based. vRet dimensioned in proc.
Dim nC As Long, sT As String
Dim LB As Long, UB As Long
If sIn = "" Then
MsgBox "Empty string - closing"
Exit Function
End If
'allocate array for chosen lower bound
If bLB1 = True Then
ReDim vRet(1 To Len(sIn))
Else
ReDim vRet(0 To Len(sIn) - 1)
End If
LB = LBound(vRet): UB = UBound(vRet)
'load charas of string into array
For nC = LB To UB
If bLB1 = True Then
sT = Mid$(sIn, nC, 1)
Else
sT = Mid$(sIn, nC + 1, 1)
End If
vRet(nC) = sT
Next
StrTo1DArr = True
End Function
Function Arr1DToStr(vIn As Variant) As String
' Makes a single string from 1D array string elements.
' Works for any array bounds.
Dim nC As Long, sT As String, sAccum As String
Dim LB As Long, UB As Long
LB = LBound(vIn): UB = UBound(vIn)
'join characters of array into string
For nC = LB To UB
sT = vIn(nC)
sAccum = sAccum & sT
Next
Arr1DToStr = sAccum
End Function
See Also
External Links
Array Data To Immediate Window
Summary
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 Notes
- 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 Module
Copy the entire code module into a standard VBA module, save the file as type .xlsm and run the top procedure. Be sure to set monospaced fonts for the VBA editor or the object will have been defeated.
Updates
- 26 Nov 2019: Adjusted DispArrInImmWindow() code to better estimate maximum column width, taking account of imposed decimal places.
Option Explicit
Private Sub testDispArrInImmWindow()
'Run this to display a selection of data arrays
'in the immediate window. Auto formatting
'includes rounding and decimal point alignment.
'Alternative is to print data untouched.
'SET IMMEDIATE WINDOW FONT TO MONOSPACED
'Eg: Consolas or Courier.
Dim vArr As Variant, vArr2 As Variant, sOutput As String
'clear the immediate window
ClearImmWindow
'UNFORMATTED random length alpha strings
RndAlphaToArr vArr, 5, 6 'length setting made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random length alpha strings
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2
'UNFORMATTED random length numbers and decimals
RndNumericToArr vArr, 5, 6 'various settings made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random length numbers and decimals
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2
'UNFORMATTED random alpha and number alternating columns
RndMixedDataToArr vArr, 5, 6 'various settings made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random alpha and number alternating columns
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2, sOutput
'output whole string version to a log file
'WriteToFile sOutput, ThisWorkbook.Path & "\MyLongArray.txt"
End Sub
Private Sub ClearImmWindow()
'NOTES
'Clears VBA immediate window down to the insertion point,
'but not beyond. Not a problem as long as cursor is
'at end of text, but otherwise not.
'Clear manually before any neat work.
'Manual clear method: Ctrl-G then Ctrl-A then Delete.
'Max display in immediate window is 199 lines,
'then top lines are lost as new ones added at bottom.
'No reliable code method exists.
Debug.Print String(200, vbCrLf)
End Sub
Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
Optional ByVal nNumDecs As Integer = 2, _
Optional sOut As String)
'--------------------------------------------------------------------------
'vA : Input 2D array for display in the immediate window.
'sOut: Alternative formatted output string.
'bFormatAlignData : True: applies decimal rounding and decimal alignment,
' False: data untouched with only basic column spacing.
'nNumDecs: Sets the rounding up and down of decimal places.
' Integers do not have zeros added at any time.
'Clear the immediate window before each run for best results.
'The immediate window at best lists 199 lines before overwrite, so
'consider using sOut for large arrays. 'ie; use it in a text file
'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
'so set the font VBA editor or any textbox to Courier or Consolas.
'To set different formats for EVERY column of an array it is best to add
'the formats at loading time with the procedure TabularAlignTxtOrNumber().
'--------------------------------------------------------------------------
'messy when integers are set in array and decimals is set say to 3.
'maybe the measurement of max element width should include a measure
' for any dot or extra imposed decimal places as well
'different for integers and for existing decimals
Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
Dim sPadding As String, sDecFormat As String, sR As String, sE As String
Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
Dim nMaxFieldWidth As Integer, bSkip As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
'get bounds of input array
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
ReDim vD(LB1 To UB1, LB2 To UB2) 'display
ReDim vC(LB2 To UB2) 'column max
'--------------------------------------
'set distance between fixed width
'fields in the output display
nInterFieldSpace = 3
'not now used
nMaxFieldWidth = 14
'--------------------------------------
If nNumDecs < 0 Then
MsgBox "nNumDecs parameter must not be negative - closing"
Exit Sub
End If
'find widest element in each column
'and adjust it for any imposed decimal places
For c = LB2 To UB2
n = 0: m = 0
For r = LB1 To UB1
'get element length
If IsNumeric(vA(r, c)) Then
If Int(vA(r, c)) = vA(r, c) Then 'is integer
n = Len(vA(r, c)) + 1 + nNumDecs
Else 'is not integer
If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
n = Len(vA(r, c))
Else 'add the difference in length as result of imposed decimal places
n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
End If
End If
Else
n = Len(vA(r, c))
End If
If n > m Then m = n 'update if longer
Next r
'store the maximum length
'of data in each column
vC(c) = m
Next c
For c = LB2 To UB2
For r = LB1 To UB1
sE = Trim(vA(r, c))
If bFormatAlignData = False Then
sDecFormat = sE
nP = InStr(sE, ".")
bSkip = True
End If
'make a basic format
If bSkip = False Then
nP = InStr(sE, ".")
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
'alpha
ElseIf IsNumeric(sE) = False Then
sDecFormat = sE
End If
End If
'adjust field width to widest in column
bSkip = False
sPadding = Space$(vC(c))
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'alpha
ElseIf IsNumeric(sE) = False Then
vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
End If
Next r
Next c
'output
sOut = ""
For r = LB1 To UB1
For c = LB2 To UB2
sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
Next c
Debug.Print sR 'print one row in imm window
sOut = sOut & sR & vbCrLf 'accum one row in output string
sR = ""
Next r
sOut = sOut & vbCrLf
Debug.Print vbCrLf
End Sub
Private Sub RndAlphaToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random string lengths
Dim sT As String, sAccum As String, nMinLenStr As Integer
Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
Dim nAsc As Integer, r As Long, c As Long
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set minimum and maximum strings lengths here
nMinLenStr = 2 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
'make one random length string
For n = 1 To nLenWord
nAsc = Int((90 - 65 + 1) * Rnd + 65)
sT = Chr$(nAsc)
sAccum = sAccum & sT
Next n
'store string
vIn(r, c) = sAccum
sAccum = "": sT = ""
Next c
Next r
End Sub
Private Sub RndNumericToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random number lengths
Dim sT1 As String, sT2 As String, nMinLenDec As Integer, sSign As String
Dim sAccum1 As String, sAccum2 As String, nMaxLenDec As Integer
Dim nLenInt As Integer, nLenDecs As Integer, nMinLenInt As Integer
Dim n As Long, r As Long, c As Long, nAsc As Integer, nMaxLenInt As Integer
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenDec = 0 'the minumum decimal part length
nMaxLenDec = 4 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 4 'the maximum integer part length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
'make one random length integer string
For n = 1 To nLenInt
If nLenInt = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
ElseIf nLenInt <> 1 And n = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
Else
nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
End If
sT1 = Chr$(nAsc)
sAccum1 = sAccum1 & sT1
Next n
'make one random length decimal part
For n = 0 To nLenDecs
nAsc = Int((57 - 48 + 1) * Rnd + 48)
sT2 = Chr$(nAsc)
sAccum2 = sAccum2 & sT2
Next n
'decide whether or not a negative number
nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
If nAsc = 5 Then sSign = "-" Else sSign = ""
'store string
If nLenDecs <> 0 Then
vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
Else
vIn(r, c) = CSng(sSign & sAccum1)
End If
sT1 = "": sT2 = ""
sAccum1 = "": sAccum2 = ""
'MsgBox vIn(r, c)
Next c
Next r
End Sub
Private Sub RndMixedDataToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random string lengths
Dim sAccum As String, nMinLenStr As Integer, sSign As String
Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
Dim nAsc As Integer, r As Long, c As Long, nMaxLenDec As Integer
Dim sT As String, sT1 As String, sT2 As String, nMinLenDec As Integer
Dim sAccum1 As String, sAccum2 As String, nMinLenInt As Integer
Dim nLenInt As Integer, nLenDecs As Integer, nMaxLenInt As Integer
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenStr = 3 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
nMinLenDec = 0 'the minumum decimal part length
nMaxLenDec = 4 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 4 'the maximum integer part length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
If c Mod 2 <> 0 Then
nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
'make one random length string
For n = 1 To nLenWord
nAsc = Int((90 - 65 + 1) * Rnd + 65)
sT = Chr$(nAsc)
sAccum = sAccum & sT
Next n
'store string
vIn(r, c) = sAccum
sAccum = "": sT = ""
Else
nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
'make one random length integer string
For n = 1 To nLenInt
If nLenInt = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
ElseIf nLenInt <> 1 And n = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
Else
nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
End If
sT1 = Chr$(nAsc)
sAccum1 = sAccum1 & sT1
Next n
'make one random length decimal part
If nLenDecs <> 0 Then
For n = 1 To nLenDecs
nAsc = Int((57 - 48 + 1) * Rnd + 48)
sT2 = Chr$(nAsc)
sAccum2 = sAccum2 & sT2
Next n
Else
sAccum2 = ""
End If
'decide whether or not a negative number
nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
If nAsc = 5 Then sSign = "-" Else sSign = ""
'store string
If nLenDecs <> 0 Then
vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
Else
vIn(r, c) = CSng(sSign & sAccum1)
End If
sT1 = "": sT2 = ""
sAccum1 = "": sAccum2 = ""
End If
Next c
Next r
End Sub
Sub testNumDecAlign()
'produces examples in immediate window for single entries
'clear the immediate window
ClearImmWindow
Debug.Print "|" & TabularAlignTxtOrNum(Cos(30), 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum("Text Heading", 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum(345.746453, 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum(56.5645, 0, 12) & "|"
Debug.Print vbCrLf
End Sub
Private Function TabularAlignTxtOrNum(vIn As Variant, nNumDecs As Integer, _
nFieldWidth As Integer) As String
'Notes:
'Returns vIn in function name, formatted to given number of decimals,
'and padded for display. VIn can contain an alpha string, a numeric
'string, or a number. nNumDecs is intended number of decimals
'in the output and nFieldWidth is its total padded width.
'Non-numerics are left-aligned and numerics are right-aligned.
'Decimal alignment results when say, all of an array column is
'formatted with the same parameters.
'ASSUMES THAT A MONOSPACED FONT WILL BE USED FOR DISPLAY
Dim sPadding As String, sDecFormat As String
'make a format based on whether numeric and how many decimals
If IsNumeric(vIn) Then
If nNumDecs > 0 Then 'decimals
sDecFormat = Format$(vIn, "0." & String$(nNumDecs, "0"))
Else
sDecFormat = Format$(vIn, "0") 'no decimals
End If
Else
sDecFormat = vIn 'non numeric
End If
'get a space string equal to max width
sPadding = Space$(nFieldWidth)
'combine and limit width
If IsNumeric(vIn) Then
'combine and limit width
TabularAlignTxtOrNum = Right$(sPadding & sDecFormat, nFieldWidth)
Else
TabularAlignTxtOrNum = Left$(sDecFormat & sPadding, nFieldWidth)
End If
End Function
Function WriteToFile(sIn As String, sPath As String) As Boolean
'REPLACES all content of text file with parameter string
'makes file if does not exist
'no layout or formatting - assumes external
Dim Number As Integer
Number = FreeFile 'Get a file number
'write string to file
Open sPath For Output As #Number
Print #Number, sIn
Close #Number
WriteToFile = True
End Function
See Also
Array Data To WorkSheet (1D or 2D)
Summary
This MS Excel VBA code listing transfers data from a one or two dimensional array to a worksheet.
Code Notes
- Arr1Dor2DtoWorksheet() transfers data from an array to a specified worksheet, and at a specified location within it. It takes one-dimensional or two-dimensional arrays, and is able to distinguish between them, prior to the transfer. Non-array inputs are detected as are arrays that are not allocated. One-dimensional arrays are transferred into a sheet row in all cases. Two-dimensional arrays are displayed in the same row and column shape as in the array. There are no facilities in the procedure to transpose data, but procedures exist elsewhere in this series for that purpose.
The VBA Module
- Copy the entire code listing into a VBA standard module and run the top procedure. Save the worksheet as type .xlsm. Comment and de-comment lines in the top procedure and adjust parameters to test the main procedure.
Sub TestArr1Dor2DtoWorksheet()
Dim vB As Variant, vC As Variant, a() As String, sE As String
Dim r As Long, c As Long, oSht As Worksheet
'preliminaries
Set oSht = ThisWorkbook.Worksheets("Sheet2")
oSht.Activate
oSht.Cells.Clear
oSht.Cells(1, 1).Select
'load a one dimensional array to test
'vB = Array("a", "b", "c", "d") 'array and allocated one dimension
vB = Split("A B C D E F G H I J K L M", " ")
'load a two dimensional array to test
ReDim vC(1 To 4, 1 To 4)
For r = 1 To 3
For c = 1 To 4
vC(r, c) = CStr(r & "," & c)
Next c
Next r
'Use these to test if input filters
'Arr1Dor2DtoWorksheet sE, "Sheet2", 3, 3 'run to test not-an-array feature
'Arr1Dor2DtoWorksheet a(), "Sheet2", 3, 3 'run to test not-allocated feature
'print arrays on sheet
Arr1Dor2DtoWorksheet vB, "Sheet2", 2, 2 '1D to sheet row
Arr1Dor2DtoWorksheet vC, "Sheet2", 5, 2 '2D to sheet range
End Sub
Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
ByVal nRow As Long, ByVal nCol As Long) As Boolean
'Transfers a one or two dimensioned input array vA to the worksheet,
'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
'CHECK THE INPUT ARRAY
On Error Resume Next
'is it an array
If IsArray(vA) = False Then
bProb = True
End If
'check if allocated
nR = UBound(vA, 1)
If Err.Number <> 0 Then
bProb = True
End If
Err.Clear
If bProb = False Then
'count dimensions
On Error Resume Next
Do
nD = nD + 1
nR = UBound(vA, nD)
Loop Until Err.Number <> 0
Else
MsgBox "Parameter is not an array" & _
vbCrLf & "or is unallocated - closing."
Exit Function
End If
'get number of dimensions
Err.Clear
nDim = nD - 1: 'MsgBox nDim
'get ref to worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
'set a worksheet range for array
Select Case nDim
Case 1 'one dimensional array
LBR = LBound(vA): UBR = UBound(vA)
Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
Case 2 'two dimensional array
LBR = LBound(vA, 1): UBR = UBound(vA, 1)
LBC = LBound(vA, 2): UBC = UBound(vA, 2)
Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
Case Else 'unable to print more dimensions
MsgBox "Too many dimensions - closing"
Exit Function
End Select
'transfer array values to worksheet
rng.Value = vA
'release object variables
Set oSht = Nothing
Set rng = Nothing
'returns
Arr1Dor2DtoWorksheet = True
End Function
See Also
Array Output Transfers
Summary
This VBA code module demonstrates four basic methods of array display. It is intended to run in MS Excel, though with the exception of the first method, transfer to the worksheet, it could be adapted easily for MS Word or other MS Office applications that run VBA.
Code Notes
- The code first loads an array with selected random data. Then the entire array is transferred to the worksheet. The data is further formatted and displayed in the immediate window, in well spaced columns. An additional copy of the formatted output is passed to the clipboard for further external use, and it is also sent to a text file to illustrate the method.
- RndDataToArr() can load an array with random data. The data types can be set as parameters, and further limits can be found within the procedure itself. Alpha, integer, decimal, dates, and mixed data are available, most random in both length and content.
- Arr1Dor2DtoWorksheet() can transfer either a one-dimensional or two dimensional array to a worksheet. It can be positioned at any location. It checks that an array exists,that it is allocated, and its number of dimensions in setting the transfer range.
- DispArrInImmWindow() formats and displays a 2D array in the immediate window of the VBA editor. It takes account of all data length in setting the well aligned columns. There are parameters to set maximum decimal places and the choice of decimal point alignment or raw data. The layout can handle mixed columns of text and numbers, though it has best appearance when all data of a column is of the same type. The whole array's formatted output is available as a single string for external use, useful for arrays beyond 199 rows, as too big for the immediate window.
- CopyToClip() is used to pass a string to the clipboard. It is used here to upload the formatted array string. The clipboard will retain the contents only until the calling application (Excel) closes. It should be noted that other clipboard procedures in this series retain their content until the Windows platform closes.
- GetFromClip() retrieves the contents of the clipboard. It is used here purely for demonstration. It passes the entire formatted string of the array to a text file.
- WriteToFile() opens and writes to a named text file. It completely replaces any text that it already contains. If the file does not exist the procedure makes it, in the same directory as the Excel file itself.
The VBA Code Module
Copy the entire code listing into an Excel VBA module, and run the top procedure to test the four array transfer methods. Save the file as type xlsm. The code writes to Sheet1, and to the immediate window of the VBA editor. Further array listings will be found on the clipboard and in a text file made for the purpose.
Option Explicit
Private Sub ArrayOutputTests()
' Test procedure for array display
'1 array to worksheet
'2 formatted array to immediate window
'3 formatted array to clipboard
'4 formatted array to text file
Dim vA As Variant, vB As Variant
Dim sArr As String, oSht As Worksheet
Dim sIn As String, sOut As String, sSheet As String
'-------------------------------------------
'choose worksheet for display
'-------------------------------------------
sSheet = "Sheet1"
Set oSht = ThisWorkbook.Worksheets(sSheet)
'-------------------------------------------
'load an array to test
'-------------------------------------------
RndDataToArr vA, 16, 10, "mixed"
vB = vA
'-------------------------------------------
'array to the worksheet
'-------------------------------------------
'clear the worksheet
oSht.Cells.Clear
'transfer array
Arr1Dor2DtoWorksheet vA, "Sheet1", 1, 1
'format columns of the sheet
With oSht.Cells
.Columns.AutoFit
.NumberFormat = "General"
.NumberFormat = "0.000" 'two decimals
End With
'-------------------------------------------
'array formatted and to the immediate window
'-------------------------------------------
'clear the immediate window
ClearImmWindow
'formatted array to immediate window
DispArrInImmWindow vB, True, 3, sIn
'get formatted array string for further use
sArr = sIn
'--------------------------------------------
'array formatted and to the clipboard
'--------------------------------------------
'formatted array string to clipboard
CopyToClip sArr
'--------------------------------------------
'array formatted and to a text file or log
'--------------------------------------------
'retrieve clipboard string
sOut = GetFromClip
'formatted array string replaces text file content
WriteToFile sOut, ThisWorkbook.Path & "\MyLongArray.txt"
'---------------------------------------------
'release object variables
'---------------------------------------------
Set oSht = Nothing
End Sub
Private Sub RndDataToArr(vIn As Variant, nRows As Integer, nCols As Integer, sType As String)
'Loads a 2D array in place with a choice of random alpha strings
'numbers or dates.
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
Dim nMinLenStr As Integer, nMaxLenStr As Integer
Dim nMinLenDec As Integer, nMaxLenDec As Integer
Dim nMinLenInt As Integer, nMaxLenInt As Integer
Dim LA As Integer, LI As Integer, sT As String, sT2 As String
Dim sAccum As String, sAccum1 As String, sAccum2 As String
Dim nDec As Single, LD As Integer, nS As Integer, sDF As String
Dim sAlpha As String, sInteger As String, sDecimal As String
Dim r As Long, c As Long, bIncMinus As String, bNeg As Boolean
Dim dMinDate As Date, dMaxDate As Date, nD As Long
'------------------------------------------------------------------------
'Parameter Notes:
'sType sets the type of data to load into the array.
' "Alpha" loads random length strings of capitals - length set below
' "Integer" loads random length integers - length set below
' "Decimal" loads random integer and decimal parts - length set below
' "Dates" loads random dates throughout - range set below
' "Mixed" loads alternate columns of alpha and decimal data - set below
'nRows is the number of required array rows
'nCols is the number of required array columns
'vIn contains the input array
'------------------------------------------------------------------------
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenStr = 3 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
nMinLenDec = 1 'the minumum decimal part length
nMaxLenDec = 3 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 5 'the maximum integer part length
dMinDate = #1/1/1900# 'earliest date to list
dMaxDate = Date 'latest date to list
sDF = "dddd, mmm d yyyy" 'random date format
bIncMinus = True 'include random minus signs
'--------------------------------------------------
'randomize using system timer
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
'get random lengths of elements
Select Case LCase(sType)
Case "alpha"
LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
Case "integer"
LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
Case "decimal"
LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
Case "mixed"
LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
Case "dates"
End Select
'make an alpha string
Do
sT = Chr$(Int((90 - 65 + 1) * Rnd + 65))
sAccum = sAccum & sT
Loop Until Len(sAccum) >= LA
sAlpha = sAccum
sAccum = "": sT = ""
'make an integer
Do
If LI = 1 Then 'zero permitted
sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
sAccum = sAccum & sT
ElseIf LI > 1 And Len(sAccum) = 0 Then 'zero not permitted
sT = Chr$(Int((57 - 49 + 1) * Rnd + 49))
sAccum = sAccum & sT
Else
sT = Chr$(Int((57 - 48 + 1) * Rnd + 48))
sAccum = sAccum & sT
End If
Loop Until Len(sAccum) >= LI
sInteger = sAccum
sAccum = "": sT = ""
'make a decimal part
Do
sT2 = Chr$(Int((57 - 48 + 1) * Rnd + 48))
sAccum2 = sAccum2 & sT2
Loop Until Len(sAccum2) >= LD
sDecimal = sAccum2
sAccum = "": sAccum2 = "": sT2 = ""
'decide proportion of negative numbers
nS = Int((3 - 0 + 1) * Rnd + 0)
If nS = 1 And bIncMinus = True Then
sInteger = "-" & sInteger
End If
'assign value to array element
Select Case LCase(sType)
Case "alpha"
vIn(r, c) = sAlpha
Case "integer"
vIn(r, c) = CLng(sInteger)
Case "decimal"
vIn(r, c) = CSng(sInteger & "." & sDecimal)
Case "dates"
nD = WorksheetFunction.RandBetween(dMinDate, dMaxDate)
vIn(r, c) = Format(nD, sDF)
Case "mixed"
If c Mod 2 = 0 Then 'alternate columns alpha and decimal
vIn(r, c) = CSng(sInteger & "." & sDecimal)
Else
vIn(r, c) = sAlpha
End If
End Select
Next c
Next r
End Sub
Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _
ByVal nRow As Long, ByVal nCol As Long) As Boolean
'Transfers a one or two dimensioned input array vA to the worksheet,
'with top-left element at cell position nRow,nCol. sSht is the worksheet name.
'Default 2D array transfers are made unchanged and a 1D array is displayed in a row.
Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean
Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long
Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant
'CHECK THE INPUT ARRAY
On Error Resume Next
'is it an array
If IsArray(vA) = False Then
bProb = True
End If
'check if allocated
nR = UBound(vA, 1)
If Err.Number <> 0 Then
bProb = True
End If
Err.Clear
If bProb = False Then
'count dimensions
On Error Resume Next
Do
nD = nD + 1
nR = UBound(vA, nD)
Loop Until Err.Number <> 0
Else
MsgBox "Parameter is not an array" & _
vbCrLf & "or is unallocated - closing."
Exit Function
End If
'get number of dimensions
Err.Clear
nDim = nD - 1: 'MsgBox nDim
'get ref to worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
'set a worksheet range for array
Select Case nDim
Case 1 'one dimensional array
LBR = LBound(vA): UBR = UBound(vA)
Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR))
Case 2 'two dimensional array
LBR = LBound(vA, 1): UBR = UBound(vA, 1)
LBC = LBound(vA, 2): UBC = UBound(vA, 2)
Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC))
Case Else 'unable to print more dimensions
MsgBox "Too many dimensions - closing"
Exit Function
End Select
'transfer array values to worksheet
rng.Value = vA
'release object variables
Set oSht = Nothing
Set rng = Nothing
'returns
Arr1Dor2DtoWorksheet = True
End Function
Private Sub ClearImmWindow()
'NOTES
'Clears VBA immediate window down to the insertion point,
'but not beyond. Not a problem as long as cursor is
'at end of text, but otherwise not.
'Clear manually before any neat work.
'Manual clear method: Ctrl-G then Ctrl-A then Delete.
'Max display in immediate window is 199 lines,
'then top lines are lost as new ones added at bottom.
'No reliable code method exists.
Debug.Print String(200, vbCrLf)
End Sub
Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
Optional ByVal nNumDecs As Integer = 2, _
Optional sOut As String)
'--------------------------------------------------------------------------
'vA : Input 2D array for display in the immediate window.
'sOut: Alternative formatted output string.
'bFormatAlignData : True: applies decimal rounding and decimal alignment,
' False: data untouched with only basic column spacing.
'nNumDecs: Sets the rounding up and down of decimal places.
' Integers do not have zeros added at any time.
'Clear the immediate window before each run for best results.
'The immediate window at best lists 199 lines before overwrite, so
'consider using sOut for large arrays. 'ie; use it in a text file
'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
'so set the font VBA editor or any textbox to Courier or Consolas.
'To set different formats for EVERY column of an array it is best to add
'the formats at loading time with the procedure TabularAlignTxtOrNumber().
'--------------------------------------------------------------------------
'messy when integers are set in array and decimals is set say to 3.
'maybe the measurement of max element width should include a measure
' for any dot or extra imposed decimal places as well
'different for integers and for existing decimals
Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
Dim sPadding As String, sDecFormat As String, sR As String, sE As String
Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
Dim nMaxFieldWidth As Integer, bSkip As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
'get bounds of input array
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
ReDim vD(LB1 To UB1, LB2 To UB2) 'display
ReDim vC(LB2 To UB2) 'column max
'--------------------------------------
'set distance between fixed width
'fields in the output display
nInterFieldSpace = 3
'not now used
nMaxFieldWidth = 14
'--------------------------------------
If nNumDecs < 0 Then
MsgBox "nNumDecs parameter must not be negative - closing"
Exit Sub
End If
'find widest element in each column
'and adjust it for any imposed decimal places
For c = LB2 To UB2
n = 0: m = 0
For r = LB1 To UB1
'get element length
If IsNumeric(vA(r, c)) Then
If Int(vA(r, c)) = vA(r, c) Then 'is integer
n = Len(vA(r, c)) + 1 + nNumDecs
Else 'is not integer
If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
n = Len(vA(r, c))
Else 'add the difference in length as result of imposed decimal places
n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
End If
End If
Else
n = Len(vA(r, c))
End If
If n > m Then m = n 'update if longer
Next r
'store the maximum length
'of data in each column
vC(c) = m
Next c
For c = LB2 To UB2
For r = LB1 To UB1
sE = Trim(vA(r, c))
If bFormatAlignData = False Then
sDecFormat = sE
nP = InStr(sE, ".")
bSkip = True
End If
'make a basic format
If bSkip = False Then
nP = InStr(sE, ".")
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
'alpha
ElseIf IsNumeric(sE) = False Then
sDecFormat = sE
End If
End If
'adjust field width to widest in column
bSkip = False
sPadding = Space$(vC(c))
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'alpha
ElseIf IsNumeric(sE) = False Then
vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
End If
Next r
Next c
'output
sOut = ""
For r = LB1 To UB1
For c = LB2 To UB2
sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
Next c
Debug.Print sR 'print one row in imm window
sOut = sOut & sR & vbCrLf 'accum one row in output string
sR = ""
Next r
sOut = sOut & vbCrLf
Debug.Print vbCrLf
End Sub
Private Function CopyToClip(sIn As String) As Boolean
'passes the parameter string to the clipboard
'set reference to Microsoft Forms 2.0 Object Library.
'Clipboard cleared when launch application closes.
Dim DataOut As DataObject
Set DataOut = New DataObject
'first pass textbox text to dataobject
DataOut.SetText sIn
'then pass dataobject text to clipboard
DataOut.PutInClipboard
'release object variable
Set DataOut = Nothing
CopyToClip = True
End Function
Private Function GetFromClip() As String
'passes clipboard text to function name
'If clipboard not text, an error results
'set reference to Microsoft Forms 2.0 Object Library.
'Clipboard cleared when launch application closes.
Dim DataIn As DataObject
Set DataIn = New DataObject
'clipboard text to dataobject
DataIn.GetFromClipboard
'dataobject text to function string
GetFromClip = DataIn.GetText
'release object variable
Set DataIn = Nothing
End Function
Private Function WriteToFile(sIn As String, sPath As String) As Boolean
'REPLACES all content of text file with parameter string
'makes file if does not exist
'no layout or formatting - assumes external
Dim Number As Integer
Number = FreeFile 'Get a file number
'write string to file
Open sPath For Output As #Number
Print #Number, sIn
Close #Number
WriteToFile = True
End Function
See Also
Charts from Arrays
Summary
Charts can be either embedded, where they are found in association with worksheets, or can occupy sheets of their own. The code example below makes basic charts on their own sheets. Purely to test the code, there is a procedure to fetch a selection of cells from the worksheet. Clearly, this procedure is justified only for testing since there are easier ways to make charts starting from a selection of cells. Array charting is generally most useful when data is not first written to a worksheet.
The chart procedure runs from an array. The array can contain one X series, and any practical number of Y series. However, the layout of the array is strict; the first row must contain only X data. All other rows will be treated as having Y series data in them. No heading labels can be included.
If the source data has its series in columns instead of the rows required by the chart array, then the data is transposed before the charting point. A transpose procedure is included in the code.
The code can be tested as a self-contained standard module.
The VBA Code
Because there are too many variations of chart types to accommodate with any accuracy, only the most general properties can be considered in one procedure. As a result, the user should add any specific code to the appropriate sections.
Note that in the supporting procedures, both empty selections and insufficient selections generate errors, so a minimal error handling was added.
Option Explicit
Sub ChartFromSelection()
'select a block of cells to chart - then run;
'either; top row X data, and all other rows Y series, or
'first column X data, and all columns Y series;
'set boolean variable bSeriesInColumns to identify which:
'Do not include heading labels in the selection.
Dim vA As Variant, bOK1 As Boolean, bOK2 As Boolean
Dim bTranspose As Boolean, bSeriesInColumns As Boolean
'avoid errors for 'no selection'
On Error GoTo ERR_HANDLER
'set for series in rows (True), or in columns (False)
bSeriesInColumns = False
'load selection into array
LoadArrSelectedRange vA, bSeriesInColumns
'make specified chart type
ChartFromArray vA, xlLine
'advise complete
MsgBox "Chart done!"
ActiveChart.ChartArea.Activate
Exit Sub
ERR_HANDLER:
Select Case Err.Number
Case 13 'no selection made
Err.Clear
MsgBox "Make a 2D selection of cells"
Exit Sub
Case Else
Resume Next
End Select
End Sub
Public Function LoadArrSelectedRange(vR As Variant, Optional bTranspose As Boolean = False) As Boolean
'gets the current selection of cells - at least 2 cols and 2 rows, ie, 2 x 2
'and returns data array in vR
'if bTranspose=True then selection is transposed before loading array
'before array storage - otherwise as found
Dim vA As Variant, rng As Range
Dim sht As Worksheet, vT As Variant
Dim r As Long, c As Long
Dim lb1, ub1, lb2, ub2
Dim nSR As Long, nSC As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'make sure a range is selected
If TypeName(Selection) <> "Range" Then Exit Function
'find bounds of selection
With Application.Selection
nSR = .Rows.Count
nSC = .Columns.Count
End With
'check that enough data is selected
If nSC < 2 Or nSR < 2 Then
MsgBox "No useful selection was found." & vbCrLf & _
"Needs at least two rows and two columns" & vbCrLf & _
"for array 2D loading."
Exit Function
End If
'dimension work array
ReDim vA(1 To nSR, 1 To nSC)
'get range of current selection
Set rng = Application.Selection
'pass range of cells to array
vA = rng
'output transposed or as found
If bTranspose = True Then
TransposeArr2D vA, vT
vR = vT
Else
vR = vA
End If
'collapse selection to top left
sht.Cells(1, 1).Select
'transfers
LoadArrSelectedRange = True
End Function
Function ChartFromArray(ByVal vA As Variant, Optional vChartType As Variant = xlLine) As Boolean
'assumes multi series are in array ROWS
'if data in columns then transpose it before call
'at this point vA must have X values in first row
'and all other rows assumed to be Y series
'only data - no label columns
'Chart type notes
'================================
'xlArea,
'xlBarClustered
'xlLine, xlLineMarkers
'xlXYScatter, xlXYScatterLines
'xlPie, xlPieExploded
'xlRadar, xlRadarMarkers
'xlSurface, xlSurfaceTopView
'see link in ChartType help page
'for full list of chart types
'================================
Dim lb1 As Long, ub1 As Long, lb2 As Long, ub2 As Long
Dim X As Variant, Y As Variant, oChrt As Chart
Dim n As Long, m As Long, S As Series, bTrimAxes As Boolean
Dim sT As String, sX As String, sY As String
'set axes labels
sT = "Top Label for Chart Here"
sX = "X-Axis Label Here"
sY = "Y-Axis Label Here"
'set boolean to True to enable axes trimming code block
bTrimAxes = False
'get bounds of array
lb1 = LBound(vA, 1): ub1 = UBound(vA, 1)
lb2 = LBound(vA, 2): ub2 = UBound(vA, 2)
ReDim X(lb2 To ub2) '1 to 11 data
ReDim Y(lb2 To ub2) '1 to 11 data
'make a chart
Set oChrt = Charts.Add
'use parameter chart type
oChrt.ChartType = vChartType
'load the single X series
For n = lb2 To ub2
X(n) = vA(lb1, n)
Next n
'remove unwanted series
With oChrt
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
End With
'add the intended series
For m = 2 To ub1
'load one Y series at a time
For n = lb2 To ub2
Y(n) = vA(m, n)
Next n
'make new series object
Set S = ActiveChart.SeriesCollection.NewSeries
'transfer series individually
With S
.XValues = X
.Values = Y
.Name = "Series names"
End With
Next m
'APPLY ALL OTHER CHART PROPERTIES HERE
On Error Resume Next 'avoid display exceptions
With oChrt
'CHART-SPECIFIC PROPERTIES GO HERE
Select Case .ChartType
Case xlXYScatter
Case xlLine
Case xlPie
Case xlRadar
Case xlSurface
End Select
'GENERAL CHART PROPERTIES GO HERE
'labels for the axes
.HasTitle = True
.ChartTitle.Text = sT 'chart title
.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
.Axes(xlCategory).AxisTitle.Text = sX 'X
.SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
.Axes(xlValue).AxisTitle.Text = sY 'Y
.Legend.Delete
If bTrimAxes = True Then
'X Axis limits and such- set as required
.Axes(xlCategory).Select
.Axes(xlCategory).MinimumScale = 0
.Axes(xlCategory).MaximumScale = 1000
.Axes(xlCategory).MajorUnit = 500
.Axes(xlCategory).MinorUnit = 100
Selection.TickLabelPosition = xlLow
'Y Axis limits and such- set as required
.Axes(xlValue).Select
.Axes(xlValue).MinimumScale = -0.2
.Axes(xlValue).MaximumScale = 1.2
.Axes(xlValue).MajorUnit = 0.1
.Axes(xlValue).MinorUnit = 0.05
End If
End With
On Error GoTo 0
oChrt.ChartArea.Select
Set oChrt = Nothing
Set S = Nothing
ChartFromArray = True
End Function
Function TransposeArr2D(vA As Variant, Optional vR As Variant) As Boolean
'---------------------------------------------------------------------------------
' Procedure : Transpose2DArr
' Purpose : Transposes a 2D array; rows become columns, columns become rows
' Specifically, (r,c) is moved to (c,r) in every case.
' Options include, returned in-place with the source changed, or
' if vR is supplied, returned in that instead, with the source intact.
'---------------------------------------------------------------------------------
Dim vW As Variant
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim r As Long, c As Long, bWasMissing As Boolean
'find whether optional vR was initially missing
bWasMissing = IsMissing(vR)
If Not bWasMissing Then Set vR = Nothing
'use a work array
vW = vA
'find bounds of vW data input work array
loR = LBound(vW, 1): hiR = UBound(vW, 1)
loC = LBound(vW, 2): hiC = UBound(vW, 2)
'set vR dimensions transposed
'Erase vR 'there must be an array in the variant to erase
ReDim vR(loC To hiC, loR To hiR)
'transfer data
For r = loR To hiR
For c = loC To hiC
'transpose vW into vR
vR(c, r) = vW(r, c)
Next c
Next r
'find bounds of vW data input work array
' loR = LBound(vR, 1): hiR = UBound(vR, 2)
' loC = LBound(vR, 2): hiC = UBound(vR, 2)
TRANSFERS:
'decide whether to return in vA or vR
If Not bWasMissing Then
'vR was the intended return array
'so leave vR as it is
Else:
'vR is not intended return array
'so reload vA with vR
vA = vR
End If
'return success for function
TransposeArr2D = True
End Function
Sub LoadArrayTestData()
'loads an array with sample number data
'first row values of x 1 to 100
'next three rows y series
Dim nNS As Long, f1 As Single
Dim f2 As Single, f3 As Single
Dim vS As Variant, vR As Variant, n As Long
'dimension work array
nNS = 50
ReDim vS(1 To 4, 1 To nNS)
'make function loop
For n = 1 To nNS
f1 = (n ^ 1.37 - 5 * n + 1.5) / -40
On Error Resume Next
f2 = Sin(n / 3) / (n / 3)
f3 = 0.015 * n + 0.25
vS(1, n) = n 'X
vS(2, n) = f1 'Y1
vS(3, n) = f2 'Y2
vS(4, n) = f3 'Y3
Next n
ChartFromArray vS, xlLine
End Sub
Sub DeleteAllCharts6()
'run this to delete all ThisWorkbook charts
Dim oC
Application.DisplayAlerts = False
For Each oC In ThisWorkbook.Charts
oC.Delete
Next oC
Application.DisplayAlerts = True
End Sub
Character Frequency Charts in Excel
Summary
VBA Code Listings
At times it is useful to make an Excel chart from VBA. The code below makes a frequency bar chart based on a given string. It is shown in testing mode with a random string input. The user should replace that string with his own. There are various charting options.
Option Explicit
Sub Test()
'run this to test the charting of this module
Dim str As String, n As Long
'make random mixed characters (for testing only)
str = MakeLongMixedString(10000)
'make a sorted frequency chart of the characters in str
MakeCharaFreqChart str, 1, "n"
MsgBox "Chart done"
End Sub
Function MakeLongMixedString(nNumChr As Long) As String
'Makes a long capital letters string using rnd VBA function
Dim n As Long, sChr As String, nAsc As Long
Dim nSamp As Long, sAccum As String, c As Long
'========================================================================
' Notes and Conclusions:
' The VBA function rnd is UNSUITED to generation of long random strings.
' Both length and number of repeats increases rapidly near 256 charas.
' Reasonable results can be obtained by keeping below 128 characters.
' For longer strings, consider hash-based methods of generation.
'========================================================================
Do Until c >= nNumChr
DoEvents
Randomize
'A to Z corresponds to asci 65 to 90
nSamp = Int((90 - 48 + 1) * Rnd + 48)
If (nSamp >= 48 And nSamp <= 57) Or (nSamp >= 65 And nSamp <= 90) Then
sChr = Chr(nSamp)
sAccum = sAccum & sChr
c = c + 1
End If
Loop
'MsgBox sAccum
MakeLongMixedString = sAccum
End Function
Sub MakeCharaFreqChart(str As String, bSort As Boolean, sYUnits As String)
'For use in Excel
'makes a character frequency chart using the parameter string str
'bSort=True to sort the chart from highest (left) otherwise unsorted
'sYUnits string sets measurement method, number charas, percentage total, or normalised to max value
Dim vC As Variant, nRow As Long, vRet As Variant
GetCharaCounts str, vC
Select Case LCase(sYUnits)
Case "n", "numbers", "number", "count", "#"
nRow = 1
Case "p", "percent", "percentage", "%"
nRow = 2
Case "r", "relative", "normalized", "normalised"
nRow = 3
End Select
If bSort Then
SortColumns vC, 1, 0, vRet
ChartColumns vRet, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
"Character Set of Interest", "Number of Each"
Else
ChartColumns vC, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
"Character Set of Interest", "Number of Each"
End If
End Sub
Sub GetCharaCounts(sIn As String, vR As Variant)
'loads an array with character counts
Dim vRef As Variant, LBC As Long, UBC As Long, LBR As Long, UBR As Long
Dim vW() As Variant, X() As Variant, Y() As Variant, vRet As Variant
Dim sUC As String, nC As Long, n As Long, sS As String, ValMax As Variant
'Notes for vR and vW loads
'Row 0: the ref chara set from vRef
'Row 1: the number of hits found in str for each chara in ref set
'Row 2: the percentage that hits rep of total charas in str
'Row 3: the normalized values for each chara with max as unity
If sIn = "" Then
MsgBox "Empty input string - closing"
Exit Sub
End If
'load the intended x-axis display set here...add to it or subtract as required
vRef = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
"N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9") ' ,"(", ")", ":", ".", ",")
LBC = LBound(vRef): UBC = UBound(vRef)
ReDim vW(0 To 3, LBC To UBC)
LBR = LBound(vW, 1): UBR = UBound(vW, 1)
ReDim X(LBC To UBC)
ReDim Y(LBC To UBC)
sUC = UCase(sIn)
nC = Len(sIn)
For n = LBC To UBC
vW(0, n) = vRef(n) 'all charas to first row
sS = vW(0, n)
'count hits in string for each chara in ref set
vW(1, n) = UBound(Split(sUC, sS)) - LBound(Split(sUC, sS)) 'count hits
'calculate hits as percentages of total chara count
vW(2, n) = Round(((vW(1, n)) * 100 / nC), 1)
Next n
'find max value in array count
SortColumns vW, 1, False, vRet
ValMax = vRet(1, 0)
'normalize to unity as max value
For n = LBC To UBC
vW(3, n) = Round(vW(1, n) / ValMax, 1)
Next n
vR = vW()
End Sub
Sub ChartColumns(ByVal VA As Variant, bColChart As Boolean, RowX As Long, RowY As Long, _
Optional bXValueLabels As Boolean = 0, Optional sTitle As String = "", _
Optional sXAxis As String, Optional sYAxis As String)
'this is the actual chart procedure. It charts the array data in VA
'the array must contain two data rows for the chart; with x and y data
'the chart can be column or scatter chart; RowX and RowY parameters identify the data rows for each axis.
'optional parameters are included for value labels, chart title, x axis label, and y axis label
Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long
Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
LBR = LBound(VA, 1): UBR = UBound(VA, 1)
LBC = LBound(VA, 2): UBC = UBound(VA, 2)
ReDim X(LBC To UBC)
ReDim Y(LBC To UBC)
'labels for specific charts
If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
MsgBox "Parameter data rows out of range in ChartColumns - closing"
Exit Sub
End If
'transfer data to chart arrays
For n = LBC To UBC
X(n) = VA(RowX, n) 'x axis data
Y(n) = VA(RowY, n) 'y axis data
Next n
'make chart
Charts.Add
'choose a column chart or a scatter chart
If bColChart Then
ActiveChart.ChartType = xlColumnClustered 'column chart
Else
ActiveChart.ChartType = xlXYScatterLinesNoMarkers 'line scatter chart
'ActiveChart.ChartType = xlXYScatter 'point scatter chart
End If
'assign the data and labels to a series
With ActiveChart.SeriesCollection
If .Count = 0 Then .NewSeries
If bXValueLabels And bColChart Then
.Item(1).ApplyDataLabels Type:=xlDataLabelsShowValue
'item(1).DataLabels.Orientation = xlUpward
.Item(1).DataLabels.Orientation = 60
End If
If Val(Application.Version) >= 12 Then
.Item(1).Values = Y
.Item(1).XValues = X
Else
.Item(1).Select
Names.Add "_", X
ExecuteExcel4Macro "series.x(!_)"
Names.Add "_", Y
ExecuteExcel4Macro "series.y(,!_)"
Names("_").Delete
End If
End With
'apply title string, x and y axis strings, and delete legend
With ActiveChart
.HasTitle = True
.ChartTitle.Text = sT
.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
.Axes(xlCategory).AxisTitle.Text = sX
.SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
.Axes(xlValue).AxisTitle.Text = sY
.Legend.Delete
End With
ActiveChart.ChartArea.Select
End Sub
Sub SortColumns(ByVal VA As Variant, nRow As Long, bAscend As Boolean, vRet As Variant)
'bubblesorts the input array's columns using values in the specified row, ascending or descending, ret in vRet
Dim i As Long, j As Long, bCond As Boolean, Y As Long, t As Variant
Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long
LBR = LBound(VA, 1): UBR = UBound(VA, 1)
LBC = LBound(VA, 2): UBC = UBound(VA, 2)
For i = LBC To UBC - 1
For j = LBC To UBC - 1
If bAscend Then
bCond = VA(nRow, j) > VA(nRow, j + 1)
Else
bCond = VA(nRow, j) < VA(nRow, j + 1)
End If
If bCond Then
For Y = LBR To UBR
t = VA(Y, j)
VA(Y, j) = VA(Y, j + 1)
VA(Y, j + 1) = t
Next Y
End If
Next j
Next i
vRet = VA
End Sub
Sub DeleteAllWorkbookCharts()
'run this manually to delete all charts
'not at this stage called in any procedure
Dim oC
Application.DisplayAlerts = False
For Each oC In ThisWorkbook.Charts
oC.Delete
Next oC
Application.DisplayAlerts = True
End Sub
Clipboard VBA
Summary
There are three main ways to pass text to and from the clipboard with VBA code.
- The DataObject method:
- This is perhaps the simplest implementation.
- Its main restriction is that the contents of the clipboard will be lost when the launching application is closed; generally this is not a problem when running Excel modules, but should be borne in mind.
- Some users elsewhere report bugs. See DataObject Bugs Forum for details of the bugs and one suggested fix. All of the procedures on this page are tested and work well in both Windows 7 and Windows 8.1 for Excel 2010. The DataObject method has recently been adopted for the VBA Indenter module, in this same series.
- Other methods avoid these restrictions. In the unlikely event of problems with these procedures, either of the next two methods would suffice.
- An example of the DataObject method is given in section two of this page.
- User form control methods:
- When user forms are to be displayed, then the copy and paste methods of the text box can be used. These methods work well and are well tested.
- When no user form is to be displayed, a hidden form can be used. The form with a text box, is loaded but never displayed. Then, the invisible user form's controls can still then be coded as normal. The text box must have its Multiline property set to true for most useful text transfers. It will be found best, in general,to set the form's ShowModal property to False; this allows for convenient code tracing and avoids many other confusions.
- An example of the hidden user form method is given in section four. Another example in section three, for a visible user form, shows how to track the active text box prior to copy.
- API methods:
- These methods make use of Windows libraries, and have copious declarations in their module headings. That said, they work well, and are described by Microsoft documentation as being the most suitable.
- One example of API use is displayed in section five. See Send-Information-to-the-Clipboard for more details.
DataObject Method
- These methods make used of a DataObject . They are by far the most adaptable, since any text that can be placed in a variable can then be placed onto the clipboard using the PutInClipboard method. Text can also be brought into a VBA string variable with the GetFromClipboard method. The procedures CopyToClip() and GetFromClip() in the example below first send text to the clipboard, then fetch it again, before displaying the text in a message box. Set a reference to Microsoft Forms 2 in the editor options for this; if you cannot find it just add a user form to your project and it will be added to the selections.
- Reports of bugs in DataObject methods are reported elsewhere. These apply to Windows versions beyond Win 7, and are reported to involve an unusual persistence between the object and the clipboard. If difficulty is found with these methods then either the dummy userform method or the API methods could be tried.
Sub testCopyAndPaste()
'demonstrates copy and paste of text to variables
'loads clipboard with date-time text then
'fetches it back for display
'Only good for text and clipboard content lost
'when application closes.
Dim sStrOut As String, sStrIn As String
'get the current date-time string
sStrOut = Now
'copy text to clipboard
CopyToClip sStrOut
'retrieve from clipboard
sStrIn = GetFromClip
'display recovered text
MsgBox sStrIn
End Sub
Function CopyToClip(sIn As String) As Boolean
'passes the parameter string to the clipboard
'set reference to Microsoft Forms 2.0 Object Library.
'If ref not listed, inserting user form will list it.
'Clipboard cleared when launch application closes.
Dim DataOut As DataObject
Set DataOut = New DataObject
'first pass textbox text to dataobject
DataOut.SetText sIn
'then pass dataobject text to clipboard
DataOut.PutInClipboard
'release object variable
Set DataOut = Nothing
CopyToClip = True
End Function
Function GetFromClip() As String
'passes clipboard text to function name
'If clipboard not text, an error results
'set reference to Microsoft Forms 2.0 Object Library.
'If ref not listed, inserting user form will list it.
'Clipboard cleared when launch application closes.
Dim DataIn As DataObject
Set DataIn = New DataObject
'clipboard text to dataobject
DataIn.GetFromClipboard
'dataobject text to function string
GetFromClip = DataIn.GetText
'release object variable
Set DataIn = Nothing
End Function
Visible User Form Method
The code module below provides the VBA code for a form module, (shown here as UserForm1). In it there are command button click routines for textbox Copy and Paste. To use the copy procedure the user simply selects some text then presses the button on the user form. To paste the contents of the clipboard into a textbox, the user must first place the insertion point somewhere within a textbox before pressing the requisite button.
In order to clarify which textbox is active, there is a mouse-up event for each, where a number is loaded into a module-level variable whenever a mouse is used in the box. Although this code is made for three textboxes, it can easily be extended to any number.
The code assumes that there is a user form UserForm1, with TextBox1, TextBox2, TextBox3, CommandButton1 and CommandButton2 in it. In addition, note that there is a module level variable in the code. Since the VBA code is fairly generic it applies to most MS Office applications.
Option Explicit
Dim nActTxtBx As Integer
Private Sub CommandButton1_Click()
'this is the "Paste at Cursor" button
'pastes clipboard active textbox's insertion point
'ie; the textbox last clicked with mouse
Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
Dim oFrm As UserForm, oTxt As Control, s As Long
Set oFrm = UserForm1
Set oTxt1 = oFrm.TextBox1
Set oTxt2 = oFrm.TextBox2
Set oTxt3 = oFrm.TextBox3
'get the textbox with the focus
Select Case nActTxtBx
Case 0
MsgBox "Please place the insertion point."
Exit Sub
Case 1
Set oTxt = oTxt1
Case 2
Set oTxt = oTxt2
Case 3
Set oTxt = oTxt3
Case Else
Exit Sub
End Select
s = oTxt.SelStart
With oTxt
.Paste
.SetFocus
.SelStart = s
End With
Set oFrm = Nothing: Set oTxt = Nothing
Set oTxt1 = Nothing: Set oTxt2 = Nothing
Set oTxt3 = Nothing
End Sub
Private Sub CommandButton2_Click()
'this is the "Copy Selected Text" button
'copies selected text from textbox to clipboard
'ie; the textbox last clicked with mouse
Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
Dim oFrm As UserForm, oTxt As Control
Set oFrm = UserForm1
Set oTxt1 = oFrm.TextBox1
Set oTxt2 = oFrm.TextBox2
Set oTxt3 = oFrm.TextBox3
'get reference to active textbox
Select Case nActTxtBx
Case 0
MsgBox "Please make a selection."
Exit Sub
Case 1
Set oTxt = oTxt1
Case 2
Set oTxt = oTxt2
Case 3
Set oTxt = oTxt3
Case Else
Exit Sub
End Select
'check that a selection was made
'MsgBox oTxt.SelLength
If oTxt.SelLength = 0 Then
MsgBox "No selection found."
Exit Sub
End If
With oTxt
.Copy
.SetFocus
.SelStart = 0
End With
Set oFrm = Nothing: Set oTxt = Nothing
Set oTxt1 = Nothing: Set oTxt2 = Nothing
Set oTxt3 = Nothing
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'loads an integer to denote active textbox when mouse makes selection
nActTxtBx = 1
End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'loads an integer to denote active textbox when mouse makes selection
nActTxtBx = 2
End Sub
Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'loads an integer to denote active textbox when mouse makes selection
nActTxtBx = 3
End Sub
Hidden User Form Method
This code should be placed in a standard module. The project needs a user form called Temp, with a single TextBox1 set with MultiLine=true. TextBox contents are always text.
Option Explicit
Sub TestClipboardProcs()
'run this
CopyToClipboard "The string" & vbCrLf & _
"to copy..."
MsgBox GetClipboard2
End Sub
Function GetClipboard2() As String
'PASTES clipboard into function name as a text string
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
Dim oTxt1 As Control, oFrm As UserForm
Dim s As Long
'load the temporary form
Load Temp
Set oFrm = Temp
Set oTxt1 = oFrm.TextBox1
s = oTxt1.SelStart
With oTxt1
.Paste
.SetFocus
.SelStart = s
End With
GetClipboard2 = oTxt1.Value
Set oTxt1 = Nothing
Set oFrm = Nothing
Unload Temp
End Function
Function CopyToClipboard(sStr As String) As Boolean
'COPIES parameter variable text string value to clipboard
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
Dim oTxt1 As Control, oFrm As UserForm
If sStr = "" Then
MsgBox "Clipboard cannot hold an empty string."
Exit Function
End If
'load the temporary form
Load Temp
Set oFrm = Temp
Set oTxt1 = oFrm.TextBox1
oTxt1.Value = sStr
'copy textbox value to clipboard
With oTxt1
.SelStart = 0 'set up the selection
.SelLength = .TextLength
.Copy
.SetFocus
.SelStart = 0
End With
Set oTxt1 = Nothing
Set oFrm = Nothing
Unload Temp
CopyToClipboard = True
End Function
API Method
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 DataObject methods for Windows 8 and 10. The code should be copied into a standard module in its entirety.
Option Explicit
'Declarations for functions SetClipboard() and GetClipboard()
''from https://docs.microsoft.com/en-us/office/vba/access/concepts/windows-api/send-information-to-the-clipboard
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Sub TestCopyPasteAPI()
'API methods for clipboard
Dim sIn As String, sOut As String
sIn = "Sausages"
SetClipboard sIn
sOut = GetClipboard
MsgBox sOut
End Sub
Public Sub SetClipboard(sUniText As String)
'sets the clipboard with parameter string
Dim iStrPtr As Long, iLen As Long
Dim iLock As Long
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
OpenClipboard 0&
EmptyClipboard
iLen = LenB(sUniText) + 2&
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
iLock = GlobalLock(iStrPtr)
lstrcpy iLock, StrPtr(sUniText)
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Function GetClipboard() As String
'gets the clipboard text in function name
Dim iStrPtr As Long, iLen As Long
Dim iLock As Long, sUniText As String
Const CF_UNICODETEXT As Long = 13&
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
iStrPtr = GetClipboardData(CF_UNICODETEXT)
If iStrPtr Then
iLock = GlobalLock(iStrPtr)
iLen = GlobalSize(iStrPtr)
sUniText = String$(iLen \ 2& - 1&, vbNullChar)
lstrcpy StrPtr(sUniText), iLock
GlobalUnlock iStrPtr
End If
GetClipboard = sUniText
End If
CloseClipboard
End Function
See Also
- Send-Information-to-the-Clipboard: A clearly worded page by Microsoft showing how to use API methods for the clipboard. Although described for MS Access, it works in MS Excel just as well.
- DataObject Bugs Forum: A description of a DataObject bug for Windows versions beyond Win7.
Simple Vigenere Cipher in VBA
Summary
- 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. A very good description of the "Key Elimination" method for cracking such simplistic keys can be found in Vigenere Cipher.
- The coded version of the cipher uses a calculation to simulate the tabular method. The twenty-six letters of the alphabet and the ten integers are assigned number values between zero and thirty-five. Then, for encryption, key values are modulo-36 added to message values to make the ciphertext. For decryption, key values are subtracted from the ciphertext, again using modulo-36 arithmetic, and always producing positive values. Numbers are converted back to characters for display.
Notes on the Code
- 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 Table
|
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 Example
The following panel shows how the calculation works for the coded version. It is analogous to the adding and subtraction of character distances within a closed set. Other implementations of the manual method have included the sliding of one set of characters against another for the required distances, sometimes using concentric discs. Figure 2 can be interpreted as a listing of every possible combination of messages and keys.
THE CHARACTER SET AND ITS VALUES
A B C D E F G H I J K L M
0 1 2 3 4 5 6 7 8 9 10 11 12
N O P Q R S T U V W X Y Z
13 14 15 16 17 18 19 20 21 22 23 24 25
0 1 2 3 4 5 6 7 8 9
26 27 28 29 30 31 32 33 34 35
ENCRYPTION WORKING
S E N D H E L P message (1)
B U L G E key
B U L G E B U L extended key (2)
18 4 13 3 7 4 11 15 message values (3)
1 20 11 6 4 1 20 11 key values (4)
19 24 24 9 11 5 31 26 (3)+(4) (5)
T Y Y J L F 5 0 cipher text (Note 1) (7)
Note 1: Subtract 36 from any numbers here that might exceed 35.
Notice that each instance of "E" results in different cipher text.
DECRYPTION WORKING
T Y Y J L F 5 0 cipher text (8)
B U L G E key
B U L G E B U L extended key (9)
19 24 24 9 11 5 31 26 cipher text values (10)
1 20 11 6 4 1 20 11 key values (11)
18 4 13 3 7 4 11 15 (10) minus (11) (12)
S E N D H E L P plain text (Note 2) (15)
Note 2: Add 36 to any numbers here that might become negative.
The VBA Code Module
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 calculation are made positive by adding 36.
'Positive results in calculation greater than 35 are reduced by 36.
'ASCI values made calculation simple here but a more general version could
'preload any character set for lookup with alternative coding.
'See Wikibooks text for a table image and further details.
End Sub
See Also
Error Handling
Summary
The code module below shows one layout method for error handling. It uses a bit more space than the usual thing but has good clarity. It also includes error logging and a block for testing the code by raising errors. Only a few errors have been listed.
Notice that no formatting is done in the log writing procedure itself, and that a choice of block logs with line separation or serial logs with comma-separation are both included.
VBA Code
Option Explicit
Sub ErrorCodeShell()
'time saving errors code shell
On Error GoTo ERR_HANDLER
'===================================
'Main body of procedure goes here...
'===================================
'===================================
' Raise Errors Here For Testing
'===================================
'Err.Raise 6 'overflow
Err.Raise 11 'div zero
'Err.Raise 53 'file not found
'Err.Raise 70 'permission denied
'===================================
Exit Sub
ERR_HANDLER:
If Err.Number <> 0 Then
'LOG ERROR DETAILS
'make error messages
Dim sE1 As String, sE2 As String
Dim oErr1 As ErrObject, oErr2 As ErrObject
'make error messages
Set oErr1 = Err: Set oErr2 = Err
sE1 = Message1(oErr1) 'block style message
sE2 = Message2(oErr2) 'serial style
Set oErr1 = Nothing: Set oErr2 = Nothing
'enable logging as block or serial format
LogError3 sE1 'write to log block style
'LogError3 sE2 'write to log serial style
'write to immediate window
Debug.Print sE1 'block style
'Debug.Print sE2 'serial style
'selective error handling
Select Case Err.Number
Case 53
GoTo FileNotFound
Case 70
GoTo PermissionDenied
Case Else:
GoTo OtherErrors
End Select
FileNotFound:
'Handle the error
Err.Clear
Exit Sub
PermissionDenied:
'Handle the error
Err.Clear
Exit Sub
OtherErrors:
MsgBox sE1
Err.Clear
Exit Sub
End If
End Sub
Function LogError3(sIn As String) As Boolean
'logs parameter string to a text file
'assumes same path as calling Excel workbook
'makes file if does not exist
'no layout or formatting - assumes external
Dim sPath As String, Number As Integer
Number = FreeFile 'Get a file number
sPath = ThisWorkbook.Path & "\error_log3.txt" 'modify path\name here
Open sPath For Append As #Number
Print #Number, sIn
Close #Number
LogError3 = True
End Function
Function Message1(oE As ErrObject) As String
'makes block style message for error
Dim sEN As String, sSrc As String
Dim sDesc As String, sDT As String
'make date-time string
sDT = Format(Now, "d mmm yyyy") & ", " & _
Format(Now, "dddd hh:mm:ss AMPM")
'get error parts
sEN = CStr(oE.Number) 'number of error
sSrc = oE.Source 'source of error
sDesc = oE.Description 'description of error
'make block message with line separations
Message1 = sDT & vbNewLine & _
"Error number: " & sEN & vbNewLine & _
"Source: " & sSrc & vbNewLine & _
"Description: " & sDesc & vbNewLine
End Function
Function Message2(oE As ErrObject) As String
'makes serial style message for error
Dim sEN As String, sSrc As String
Dim sDesc As String, sDT As String
'make date-time string
sDT = Format(Now, "dddd yyyy mmm d hh:mm:ss")
'get error parts
sEN = CStr(oE.Number) 'number of error
sSrc = oE.Source 'source of error
sDesc = oE.Description 'description of error
'make serial message with comma separations
Message2 = sDT & ",Error " & sEN & "," & sSrc & "," & sDesc
End Function
See Also
External Links
File and Folder Dialogs
Summary
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.
The two dialogs ''SelectFolder()'' and ''SelectFile()'' will work with both 32 bit and 64 bit version of MS Office, but the API procedure ''BrowseFolder()'' is not intended for 64 bit working; it works only in 32 bit systems. For completeness, another version of the API for 64 bit systems has been added at the foot of the page. Although these two look a bit similar, it is important to choose the right one for your version of MS Office. All three can be run from the test procedure.
Just copy the entire code listing into a standard module for use, and comment out the API version that is unwanted, assuming that an API is used at all.
VBA Code Module
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
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This API procedure is for 32 bit systems only; see below for a 64 bit API
' 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
Option Explicit
Option Compare Text
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As LongPtr, ByVal pszPath As String) As Long
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As LongPtr
Private Const BIF_RETURNONLYFSDIRS = &H1
Sub a_testBrowseFolder2()
'Tests the 64 bit version of the API BrowsFolder2
Dim sFPath As String
sFPath = BrowseFolder2("Please select a folder.")
MsgBox sFPath
End Sub
Public Function BrowseFolder2(Optional sTitle As String = "") As String
'This version of the BrowsFolder API is for 64 bit systems. For 32 bit systems use one at top of page
'This function returns a folder path string as selected in the browse dialog, without a trailing backslash.
'Credit is given to Peter De Baets, from which this procedure was trimmed for 64 bit only.
Dim x As Long, Dlg As BROWSEINFO
Dim DlgList As LongPtr
Dim sPath As String, Pos As Integer
Dim sRet As String
sRet = ""
With Dlg
'.hOwner = hWndAccessApp 'errors
.lpszTitle = sTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
DlgList = SHBrowseForFolder(Dlg)
sPath = Space$(512)
x = SHGetPathFromIDList(ByVal DlgList, ByVal sPath)
If x Then
Pos = InStr(sPath, Chr(0))
sRet = Left$(sPath, Pos - 1)
Else
sRet = ""
End If
BrowseFolder2 = sRet
End Function
See Also
External Links
- BrowseFolder : Chip Pearson's page on the API folder browser.
- FileDialog Properties and Methods: The Microsoft documentation for the FileDialog selection methods. It includes a code panel showing the use of file multi-selection.
Recursive File Listing of Folders
Summary
- Recursive listings are tricky, and it is found to be difficult without module or public declarations of some sort. This version although a bit clumsy will perform as expected for files that can be accessed.
- A public variable is used as a counter to keep track, between iterations, of the numbers of files found, since Microsoft advises us that static variables are not usually used with recursion. The VBA code is not specific for any particular Office application, so would work in say MS Excel or MS Word etc.
- The user might need to introduce more filtering; for example, to exclude certain file types, or to avoid those of zero size. A comment in the code listing shows where such a code function could be added to the existing condition.
- Because the array is public, it can be accessed from any other module for its further processing or output. Copy the code entirely into a code module, and modify the folder and recursion condition to your own values.
- My Documents versus Documents. There are four virtual folders in Libraries, My Documents, My Music, My Pictures, and My Videos. When the Windows Explorer's Folder Options forbid the display of hidden files, folders, and drives, the correct locations are returned by various folder selection dialogs, namely Documents, Music, Pictures, and Videos. When hidden folders are permitted, then dialogs and listings will attempt to make use of these virtual paths. Access violations will result. To avoid undue problems, check that your folder options are set not to show hidden files or folders. This procedure avoids these folders altogether, but access violations can be avoided, provided that hidden files are allowed to stay hidden.
VBA Code
Option Explicit
Option Base 1
Public vA() As String
Public N As Long
Sub MakeList()
'loads an array with details of the files in the selected folder.
Dim sFolder As String, bRecurse As Boolean
'NOTE
'The Windows virtual folders My Music, My Videos, and My Pictures
'generate (handled) error numbers 70,90,91 respectively, so are avoided.
'Alternatively, set Folder Options to not show hidden files and folders
'to avoid the problem.
'set folder and whether or not recursive search applies
sFolder = "C:\Users\My Folder\Documents\Computer Data\"
bRecurse = True
'erase any existing contents of the array
Erase vA() 'public string array
'this variable will accumulate the result of all recursions
N = 0 'initialize an off-site counting variable
'status bar message for long runs
Application.StatusBar = "Loading array...please wait."
'run the folder proc
LoadArray sFolder, bRecurse
If N = 0 Then
Application.StatusBar = "No Files were found!"
MsgBox "NO FILES FOUND"
Application.StatusBar = ""
Exit Sub
Else
'status bar message for long runs
Application.StatusBar = "Done!"
MsgBox "Done!" & vbCrLf & N & " Files listed."
Application.StatusBar = ""
Exit Sub
End If
End Sub
Sub LoadArray(sFolder As String, bRecurse As Boolean)
'loads dynamic public array vA() with recursive or flat file listing
'The Windows folders My Music, My Videos, and My Pictures
'generate error numbers 70,90,91 respectively, and are best avoided.
Dim FSO As Object, SourceFolder As Object, sSuff As String, vS As Variant
Dim SubFolder As Object, FileItem As Object, sPath As String
Dim r As Long, Count As Long, m As Long, sTemp As String
'm counts items in each folder run
'N (public) accumulates m for recursive runs
m = m + N
On Error GoTo Errorhandler
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(sFolder)
For Each FileItem In SourceFolder.Files
DoEvents
sTemp = CStr(FileItem.Name)
sPath = CStr(FileItem.path)
'get suffix from fileitem
vS = Split(CStr(FileItem.Name), "."): sSuff = vS(UBound(vS))
If Not FileItem Is Nothing Then 'add other file filter conditions to this existing one here
m = m + 1 'increment this sourcefolder's file count
'reset the array bounds
ReDim Preserve vA(1 To 6, 0 To m)
r = UBound(vA, 2)
'store details for one file on the array row
vA(1, r) = CStr(FileItem.Name)
vA(2, r) = CStr(FileItem.path)
vA(3, r) = CLng(FileItem.Size)
vA(4, r) = CDate(FileItem.DateCreated)
vA(5, r) = CDate(FileItem.DateLastModified)
vA(6, r) = CStr(sSuff)
End If
Next FileItem
'increment public counter with this sourcefolder count
N = m 'N is public
'this bit is responsible for the recursion
If bRecurse Then
For Each SubFolder In SourceFolder.SubFolders
LoadArray SubFolder.path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
Exit Sub
Errorhandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case 70 'access denied
'MsgBox "error 70"
Err.Clear
Resume Next
Case 91 'object not set
'MsgBox "error 91"
Err.Clear
Resume Next
Case Else
'MsgBox "When m = " & m & " in LoadArray" & vbCrLf & _
"Error Number : " & Err.Number & vbCrLf & _
"Error Description : " & Err.Description
Err.Clear
Exit Sub 'goes to next subfolder - recursive
End Select
End If
End Sub
File and Folder Utilities
Summary
- This first set of utilities concentrates on the basic FileSystemObject set; that is, the set used to find whether or not a file or folder exists, what their sizes are, and whether or not they have a particular attribute. A basic path parsing procedure is also provided. All of these procedures need a reference set in the VBA editor to Microsoft Scripting Runtime
- No universally useful code was found for testing for open files. Although many procedures exist, they all fail in some way, usually failing to identify open text or image files, or Office files that are marked as read-only. The basis of the problem is that many such files in Windows do not lock when opened by a user, so procedures that attempt to detect the open state by trying for sole access, cannot do so. Any reader with a universal solution is, as always, invited to comment.
VBA Notes
At times it is useful to know whether or not a file or folder has a particular attribute, for example, to avoid hidden or system files in listings. The procedure HasAttribute does this, taking a path to the file as parameter and a short-code to identify the attribute of interest. However, the attribute bundle is delivered with all of the attribute number values added together, so this type of test, like other enumerations that involve constants (eg; the message box types), makes use of the AND function to split the bundle.
For example: (See procedure HasAttribute below.) Assume that the attribute bundle from GetAttr equals 37
and that we are testing for the "system" attribute only ("S") with vbSystem = 4. Now, for numbers,
the AND operator performs a bitwise AND on each column, so gives:
01001012 = 3710 = vbArchive + vbSystem + vbReadOnly
00001002 = 410 = vbSystem
_______
00001002 = 410, interpreted by boolean variables as True since it is non-zero
That is to say, the "system" attribute is present in the attribute bundle.
If the "system" attribute were not set, then the result would have been all zeros
It is important to note that the returned value tests only one attribute at a time; that is to say, although a file returns true for for read-only ("R"), it might also have other attributes that are not tested. If users would rather have all of the file or folder attributes returned in one string, some work might be done to concatenate the result codes.
An example of file path parsing is given in the ParsePath procedure. The example uses the Split function to place all of the backslash separated terms into an array, then recombines them to make the path. A similar method, split on the dot is used to make the file name and suffix.
VBA Code Module
Option Explicit
Function FileFound(sPath As String) As Boolean
'returns true if parameter path file found
Dim fs As FileSystemObject
'set ref to fso
Set fs = CreateObject("Scripting.FileSystemObject")
'test for file
FileFound = fs.FileExists(sPath)
Set fs = Nothing
End Function
Function FolderFound(sPath As String) As Boolean
'returns true if parameter path folder found
Dim fs As FileSystemObject
'set ref to fso
Set fs = CreateObject("Scripting.FileSystemObject")
'test for folder
FolderFound = fs.FolderExists(sPath)
Set fs = Nothing
End Function
Function GetFileSize(sPath As String, nSize As Long) As Boolean
'returns file size in bytes for parameter path file
Dim fs As FileSystemObject, f As File
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(sPath) Then
Set f = fs.GetFile(sPath)
nSize = f.Size
GetFileSize = True
End If
Set fs = Nothing: Set f = Nothing
End Function
Function GetFolderSize(sPath As String, nSize As Long) As Boolean
'returns total content size in bytes for parameter path folder
Dim fs As FileSystemObject, f As Folder
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(sPath) Then
Set f = fs.GetFolder(sPath)
nSize = f.Size
GetFolderSize = True
End If
Set fs = Nothing: Set f = Nothing
End Function
Function HasAttribute(sPath As String, sA As String) As Boolean
'returns true if parameter path file or folder INCLUDES test parameter
'eg: if sA= "H" then returns true if file attributes INCLUDE "hidden"
'Untested attributes might also exist
'sA values
'"R"; read only, "H"; hidden, "S"; system, "A"; archive
'"D"; directory, "X"; alias, "N"; normal
Dim bF As Boolean, nA As Integer
Dim bFile As Boolean, bFldr As Boolean
Dim fs As FileSystemObject, f As File, fd As Folder
Set fs = CreateObject("Scripting.FileSystemObject")
'check path parameter
bFile = fs.FileExists(sPath)
bFldr = fs.FolderExists(sPath)
If bFile Or bFldr Then
'get its attribute bundle
nA = GetAttr(sPath)
Else
'neither found so exit
MsgBox "Bad path parameter"
GoTo Wayout
End If
'early exit for no attributes
If nA = 0 And sA = "N" Then '0
HasAttribute = True
Exit Function
End If
'test for attribute in sA
'logical AND on number variable bit columns
If (nA And vbReadOnly) And sA = "R" Then '1
bF = True
ElseIf (nA And vbHidden) And sA = "H" Then '2
bF = True
ElseIf (nA And vbSystem) And sA = "S" Then '4
bF = True
ElseIf (nA And vbDirectory) And sA = "D" Then '16
bF = True
ElseIf (nA And vbArchive) And sA = "A" Then '32
bF = True
ElseIf (nA And vbAlias) And sA = "X" Then '64
bF = True
End If
HasAttribute = bF
Wayout:
Set fs = Nothing: Set f = Nothing: Set fd = Nothing
End Function
Function ParsePath(sPath As String, Optional sP As String, _
Optional sF As String, Optional sS As String) As Boolean
'sPath has full file path
'returns path of file with end backslash (sP),
'file name less suffix (sF), and suffix less dot(sS)
Dim vP As Variant, vS As Variant, n As Long
Dim bF As Boolean, fs As FileSystemObject
'set ref to fso
Set fs = CreateObject("Scripting.FileSystemObject")
'test that file exists
bF = fs.FileExists(sPath)
If Not bF Then
'MsgBox "File not found"
GoTo Wayout
End If
'make array from path elements split on backslash
vP = Split(sPath, "\")
'make array from file name elements split on dot
vS = Split(vP(UBound(vP)), ".")
'rebuild path with backslashes
For n = LBound(vP) To UBound(vP) - 1
sP = sP & vP(n) & "\"
Next n
sF = vS(LBound(vS))
sS = vS(UBound(vS))
ParsePath = True
Wayout:
Set fs = Nothing
End Function
See Also
External Links
Font Utilities
Summary
- This page lists VBA procedures that are mainly to do with fonts. That is to say, how VBA handles fonts.
- The function GetTextPoints() finds the width of text in points. A label on a userform extends when loaded with the string. The width is then read from the control. The userform and its contents are loaded but never shown. Despite its seeming lack of elegance, this method is perhaps the simplest way of getting the fitting width for text, correct for any variation in the font. The function is useful in the precise sizing of controls for complex layouts, such as tables within text boxes.
- The procedure ListAllExcelFonts() lists Excel's fonts on a worksheet. It makes use of GetTextPoints(). While listing whether or not the font is monospaced, it also makes a sample of test text in each font. It also lists the width in points for the sample text in each font. Normalizing these width figures might be more useful but it is unclear as to which font is best to represent the standard. As ever, informed comments would be useful.
- The procedure FontExists() tests whether or not a font exists. It returns true in the function name if the parameter font name exists, otherwise it returns false. Run testit() to try the function.
Font Tests
The function GetTextPoints() can be used to determine whether or not a font is monospaced. Although at first sight it would appear suitable for determining the presence of kerning, the userform control used to measure the width of text does not kern the text applied to it in any case. As such, kerning will always be found to be absent. The tests, whether used visually or in an automated mode, compare the lengths of selected strings. If the strings of the first pair below are the same length, then the font is monospaced. Elsewhere, if kerning had been applied, then the strings of the second pair would be different in length.
Monospace test strings:
IIIIIIIIII
HHHHHHHHHH
Kerning test strings: for completeness only.
AAAAATTTTT
ATATATATAT
Code Module Notes
Code Module
Revisions
Sub TestGetTextPoints()
'Run this to obtain the points width of text
' Get the net width in points for the string
MsgBox GetTextPoints("The quick brown fox jumps over the lazy dog", "Consolas", 12, 0, 0) & _
" points width"
End Sub
Function GetTextPoints(sIn As String, sFontName As String, _
nFontSize As Single, bFontBold As Boolean, _
bFontItalic As Boolean) As Long
'GetTextPoints returns points width of text.
'When setting a control width, add two additional
'space widths to these values to avoid end clipping.
'Needs a user form called CountPoints. Form
'is loaded and unloaded but never shown.
'Monospace test: could be used here to identify monospaced fonts
'If pair is same width then monospaced
'IIIIIIIIII
'HHHHHHHHHH
'Kerning test pair used by printers: Wont work here since there is no kerning in userform controls.
'If pair are different width then there is kerning.
'AAAAATTTTT
'ATATATATAT
Dim oLbl As Control
Load CountPoints
Set oLbl = CountPoints.Controls.Add("Forms.Label.1", "oLbl")
'format the label with same fonts as sIn
With oLbl
.Width = 0
.WordWrap = False
.Visible = False
.AutoSize = True
.Caption = ""
.font.SIZE = nFontSize
.font.Name = sFontName
.font.Bold = bFontBold
.font.Italic = bFontItalic
End With
'get points for sIn
oLbl.Caption = sIn
GetTextPoints = oLbl.Width
Unload CountPoints
End Function
Sub ListAllExcelFonts()
'Lists Excel fonts as monospaced or proportional
'with a sample of text and its width in points
'calls GetTextPoints to measure test strings
'needs use of Sheet1 - clears all existing
Dim FontList, sht As Worksheet, i As Long
Dim sM1 As String, sM2 As String, sFN As String
Dim sTest As String, nSize As Single
Dim bBold As Boolean, bItalic As Boolean
'monospaced test strings
sM1 = "IIIIIIIIII"
sM2 = "MMMMMMMMMM"
'set a suitable test string here
sTest = "The quick brown fox jumps over the lazy dog 1234567890"
'set test parameters
nSize = 10 'ten point for all tests
bBold = False
bItalic = False
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
.Activate
.Range("A1:Z65536").ClearContents
.Range("A1:Z65536").ClearFormats
End With
'get reference to the font list
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
On Error Resume Next
'work loop
For i = 1 To FontList.ListCount
sFN = FontList.List(i) 'font name
'print general data to sheet
With sht
.Cells(i, 1) = sFN 'name
.Cells(i, 3) = GetTextPoints(sTest, sFN, nSize, bBold, bItalic) 'test string pts width
End With
'set fonts for sample cell
With sht.Cells(i, 4).font
.Name = sFN
.SIZE = nSize
.Italic = bItalic
.Bold = bBold
End With
'sample string to sheet
sht.Cells(i, 4) = sTest
'monospaced test - true if both test strings equal in length
If GetTextPoints(sM1, sFN, nSize, bBold, bItalic) = GetTextPoints(sM2, sFN, nSize, bBold, bItalic) Then
'the test font is monospaced
sht.Cells(i, 2) = "Monospaced" 'mono or prop
Else
sht.Cells(i, 2) = "Proportional"
End If
Next i
With sht
.Columns.AutoFit
.Cells(1, 1).Select
End With
End Sub
Private Sub testit()
' Find whether or not a font exists
Dim sFontName As String
sFontName = "Consolas"
If FontExists(sFontName) Then
MsgBox sFontName & " exists"
Else
MsgBox sFontName & " does not exist"
End If
End Sub
Public Function FontExists(FontName As String) As Boolean
' Returns true in function name
' if parameter font name exists
Dim oFont As New StdFont
oFont.Name = FontName
If StrComp(FontName, oFont.Name, vbTextCompare) = 0 Then
FontExists = True
End If
End Function
See Also
External Links
The Elusive Button
Summary
These VBA code modules are intended for Microsoft Excel. They show how to make a button that continually escapes attempts to click it. The code needs only a user form called UserForm1, and two command buttons, CommandButton1 and CommandButton2; The code will size the controls and the form itself.
Code Notes
- The MouseMove event applies to specific controls; in this case a CommandButton. It fires whenever the mouse moves anywhere within the area of the control, and is used here to move the control before the user can select it.
- The code proposes random direction and shift amounts, then checks to make sure that the resulting shift will stay on the form, before moving the control. When a proposed shift is rejected, the fact that the mouse is still moving ensures that another event will still fire before a selection can be made. Selection HAS been known to happen, perhaps when there is an unlikely number of rejected shift values; a click procedure has been included to note the fact, just in case.
- The VBA help page for this event has an impressive set of options, as yet unexplored here.
The ThisWorkbook Module
Copy this code into the ThisWorkbook module of the project. Save the file as xlsm type. It will run whenever the file is opened.
Private Sub Workbook_Open()
'loads the user form at file open
Load UserForm1
UserForm1.Show
End Sub
The Userform1 Module
Copy this code into the UserForm1 module. It can be accessed by double-clicking the userform in design mode. Save the file, making sure it is xlsm type. The code is run by opening the file or by clicking the above Open event procedure in the ThisWorkbook module.
Code Modifications
Added colors and overlaps, 2 Feb 2019
Added notes to code, 2 Feb 2019
Option Explicit
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Runs whenever the mouse moves anywhere on the CommandButton control.
'Shifts the control when that happens, provided that the proposed
'random shift will still allow the control to stay on the form.
Dim Lrand1 As Long, Lrand2 As Long, Lstartval As Single, LMyrand As Long
Dim Trand1 As Long, Trand2 As Long, Tstartval As Single, TMyrand As Long
'propose random horizontal jump direction and distance
Lrand1 = 1 'direction
Lstartval = Rnd 'fractional
If Lstartval < 0.5 Then Lrand1 = -1
Lrand2 = Int((70 - 45 + 1) * Rnd + 45) 'distance
LMyrand = Lrand1 * Lrand2 'direction and distance
'propose random vertical jump direction and distance
Trand1 = 1 'direction
Tstartval = Rnd 'fractional
If Tstartval < 0.5 Then Trand1 = -1
Trand2 = Int((70 - 45 + 1) * Rnd + 45) 'distance
TMyrand = Trand1 * Trand2 'direction and distance
With CommandButton1
Select Case Lrand1
Case 1 'positive shift to right
'if shift still on userform...
If .Left + LMyrand + .Width < UserForm1.Width + 10 Then
.Left = .Left + LMyrand 'shift
Else
'do nothing - will fire again
End If
Case -1 'negative shift to left
'if shift still on userform...
If .Left + LMyrand > -10 Then
.Left = .Left + LMyrand 'shift
Else
'do nothing - will fire again
End If
End Select
Select Case Trand1
Case 1 'positive shift down
'if shift still on userform...
If .Top + TMyrand + .Height < UserForm1.Height + 10 Then
.Top = .Top + TMyrand 'shift
Else
'do nothing - will fire again
End If
Case -1 'negative shift up
'if shift still on userform...
If .Top + TMyrand > -10 Then
.Top = .Top + TMyrand 'shift
Else
'do nothing - will fire again
End If
End Select
End With
End Sub
Private Sub CommandButton1_Click()
'runs if user can select button
'Rare, but it can happen
MsgBox "It had to happen sometime!"
End Sub
Private Sub CommandButton2_Click()
'runs from alternative choice
'to stop process and unload form
UserForm1.Hide
Unload UserForm1
End Sub
Private Sub UserForm_Initialize()
'runs after loading but before show
'sets initial values of form and controls
With UserForm1
.Height = 250
.Width = 250
.BackColor = RGB(9, 13, 147)
.Caption = "Ambitious?..."
End With
With CommandButton1
.Height = 55
.Width = 55
.Top = 45
.Left = 55
.BackColor = RGB(255, 172, 37)
.Caption = "Press if" & vbCrLf & "you want" & vbCrLf & "a raise"
End With
With CommandButton2
.Height = 55
.Width = 55
.Top = 45
.Left = 140
.BackColor = RGB(222, 104, 65)
.Caption = "No thanks?"
End With
End Sub
See Also
String Hashing in VBA
Summary
- 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 Listings
Notes on the Code
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 installed 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 Also
- File Hashing in VBA : A companion page in this series that lists code for single file hashing. Combine this with file listing code for extensive hashing of files.
- Folder Hashing in VBA :Another companion page that makes recursive folder hash listings, and logs. Uses up to date hash algorithms, but limited to files no larger than about 200MB.
File Hashing in VBA
Summary
- 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. In Windows 10, hashes can also be obtained at the command prompt with certutil -hashfile <full path to file to hash> MD5, though size limitations are unclear. (Change md5 to sha1, sha256, or sha512, etc).
- An external application that can handle large files is MD5 and SHA Checksum Utility. It is a stand-alone application, and a basic version is available as a free download. It produces MD5, SHA1, SHA2/256, and SHA2/512 hashes for single files. The outputs are in HEX and are displayed together on a neat user interface. A more complex commercial version is also available.
- FSUM Fast File Integrity Checker is another free, external application for command line use. It resembles FCIV in many ways but includes up to date algorithms. (MD2, MD4, MD5, SHA-1, SHA-2( 256, 384, 512), RIPEMD-160, PANAMA, TIGER, ADLER32, and CRC32). In addition to large file HEX hashes it can carry out flat or recursive folder hashes. The code to enter is not identical to that of FCIV but a text file is provided with examples in its use. The web page FSUM Fast File Integrity Checker has the download and other details, though the text file fails to mention that results can be easily piped to the clipboard with |clip. Although a graphical interface exists elsewhere, the command-line application has been found the most stable..
- The permissions for files need to be considered when attempting hashing. Hashing has to access files to obtain the bytes that they contain. Although this does not involve actually running the files, some folder and file types might be found locked at run time. In fact, this type of access is the main difference between string hashing and file hashing. Whenever files are accessed, error handling tends to be needed. It is assumed here that the user will add his own error-handling, or that he will go-around files that are troublesome before the hashing attempt. Users should know that the code cannot handle an empty text file; for example, a Notepad file that has been saved without any text in it. The GetFileBytes routine will error. A message and exit will be produced if an empty file is encountered, as for a file in excess of 200MB.
- User files and folders have few restrictions. The empty file problem apart, those who want to access user files in folders that they have made themselves will not usually have any problems, and interested parties should know that there is a recursive folder hashing module in another section of this series that might be of related interest. Folder Hashing in VBA also contains notes on how to avoid virtual folder problems with music, video, and other Microsoft libraries.
- Hashing is concerned only with the content of a file, and not its name, or other file details. This means that duplicates of files under any name can be found by comparing their hashes. In secure systems with deliberately confusing file names, this means that a very long file list could be hashed until a searched-for hash value is found, rather than depending on a less secure file name to find it. Alternatively, file names are sometimes just the file's hash value, so that hashing can reveal any error or illegal change. In such a case a hacker might change the file then name the file with a corresponding hash, but he does not know the required hash algorithm or private string to use, so changes will always be detected when the owner runs his own hash verification.
Code Listings
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 installed 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.
Modifications
- 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 VBA
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 intended 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 Also
- String Hashing in VBA : A companion page in this series for those who want only to hash strings.
- Folder Hashing in VBA :Another companion page that makes recursive folder hash listings, and logs. Uses up to date hash algorithms, but limited to files no larger than about 200MB.
- Running the FCIV Utility from VBA: How to use the Microsoft fciv.exe command line utility to make MD5 and SHA1 file hashes from VBA. The MS utility, although awkward to use, allows hashing and verification of entire folder trees.
- File Checksum Integrity Verifier (FCIV) Examples: More details on how to use the FCIV utility for those without much experience working from the command line prompt.
External Links
- MD5 and SHA Checksum Utility: a external site's free application to simultaneously display MD5,SHA1,SHA256,and SHA512 hashes of single files (Hex only). Includes a browse-for-file function and drag and drop to make life easy. This utility can also be used to hash large files; author-tested for a 500MB file.
- FSUM Fast File Integrity Checker : The basic command-line version of the FSUM hasher download.
- FSUM GUI : A graphical interface download site for the FSUM utility. This allows file browsing, drag and drop, and other facilities to simplify the otherwise command-line working.
Folder Hashing in VBA
Summary
- These modules are made for Microsoft Excel only. It hashes files in whole folders. It handles both flat and recursive folder listing, makes log files, and verifies files against hash files made previously.
- Any of five hash algorithms can be used on the worksheet. They are, MD5, SHA1, SHA256, SHA384, and SHA512,. They are displayed on Sheet1 of the workbook in either hex or base64 formats. If log files are also required for these hashes, they are made in SHA512-b64 format for future verification; this format is independent of the format chosen for worksheet listings.
- Verification results appear on Sheet2 of the workbook. Verification failures are highlighted in red. Make sure therefore that Sheet1 and Sheet2 exist in the workbook. These results can also be delivered to a log file for future use.
- Log files, when made, are found in the default folder. Make log choices on the user form's check box options.
- HashFile*.txt logs have a name that is date-stamped, and contains the number of files listed in it. Separate logs can be made for each run.
- HashErr.txt is the error log. It logs file item paths that could not be hashed. There is only one of these, and the results for each run are appended with a date-time stamp. When full, just delete it and a new one will be made as required.
- VerReport*.txt logs a copy of verification results. A separate log can be made for each verification run. It too has a date-time stamp in its file name.
- The process is slower than FCIV, but has more algorithms to choose from. However, unlike FCIV no single file can exceed about 200MB. See File Hashing in VBA for notes on ways to hash larger files. A recursive run of the Documents folder, (2091 user files, and 1.13GB in total), took seven and a half minutes. It included writing to the worksheet, making a hash log, and logging 36 filter exclusions in an error file. Verification is faster, taking about half of that time.
- A user form layout is shown in Figure 1. The exact control names are given, and these correspond exactly to those in code. The use of the same control names is essential for a trouble-free installation. Regrettably, there is no way in Wikibooks to download an Excel file, or for that matter the VBA code files themselves, so the main work is in the making of the user form.
- Set filter conditions in FilterOK(). The fastest results can be had when the filter conditions are as narrow as possible. A wide range of filter conditions can be set directly in code, and for items filtered, their paths will be listed in the error file.
- Be sure to set VBA Project references. Required are Visual Basic for Applications Extensibility 5.3, mscorlib.dll, and Microsoft Scripting Runtime, in addition to any others that you may require. The VBA editor's error setting should be Break on Unhandled Errors.
- My Documents versus Documents. There are four virtual folders in the Libraries category of the Windows Explorer, My Documents, My Music, My Pictures, and My Videos. When the Windows Explorer's Folder Options are set to NOT display hidden files, folders, drives and Operating system files, the correct locations are nonetheless returned by the folder selection dialogs, namely Documents, Music, Pictures, and Videos. When there are NO restrictions on viewing hidden and operating system files and folders, then selection dialogs will wrongly attempt to return these virtual paths, and access violations will result. It is only by avoiding this situation that easy listings can be obtained, so check that the Folder Options of Windows Explorer are set in accordance with Figure 2.
The Code Modules
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 installed 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 App
There are two main functions; making hashes on the worksheet and an optional hash log, and verifying computer folders against a previously made hash log. The hashing mode also includes an optional error log, to list both errors and files avoided by the user-set filters. Verification results use an optional log of their own. Be sure to note the required Folder Options of Figure 2 before any hashing activities.
Making hashes
- Set the options, recursion, output format, and hash algorithm in the topmost panel. Make log file selections on the check boxes.
- Select a folder to hash with Select Folder to Hash. Then, pressing the Hash Folder button starts the listing on Sheet1 of the workbook.
- Wait for the run to finish. The user form's top-caption changes to advise that the application is still processing, and message boxes advise when the run is complete. The Stop all Code button can be pressed at any time to return to the VBA editor in either of the two working modes.
- Filtered files will be ignored in hashing. These are files deliberately avoided by user settings in the FilterOK() procedure. Such files will be listed in the error file (HashErr*.txt), if selected.
- Log files are available for inspection, if such options were selected, located most often in the workbook's launch folder.
- Restrict hashing to user libraries. Owing to the large numbers of hidden and otherwise restricted files in Windows, it is recommended that hashing be restricted to the contents of the user profiles. Although some files will be restricted even there, for most this is not much of a limitation, since it still includes Documents, Downloads, Music, Pictures, and Videos, and various other folders.
Verifying Folders
The verification process verifies only those file paths that are listed on the chosen hash file, and will not even consider files added to the file folders since the hash file was made. When folders are changed, new hash files need to be made in a working system.
- Make a file selection in the bottom panel, by pressing Select File to Verify. This must be a log file (HashFile*.txt) made at an earlier time for the purpose of verification. It is the same file that can be made during a hash run, and regardless of any settings made for worksheet listing, these files will always be made as SHA512-b64 format.
- Press Start Verification to start the process. Results are listed on Sheet2 of the worksheet, and any failures are color-highlighted. The user form caption changes to advise that the application is still processing, and message boxes advise when the process is complete.
- Review the results , either on Sheet2 or in the verification results file (VerHash*.txt) in the default folder. Consider further action.
Code Modification Notes
- 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 Module
Private Sub Workbook_Open()
'displays userform for
'options and running
Load UserForm1
UserForm1.Show
End Sub
The Userform1 Module
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 Module1
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 algorithms 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 installed 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 installed 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 installed 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 installed 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 installed 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 installed 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 installed 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 installed 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 installed 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 installed 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 Also
- 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 Links
Running the FCIV Utility from VBA
Summary
The Microsoft FCIV Utility, the File Checksum Integrity Verifier , is a free downloadable zipped package that allows a user to produce both SHA1 and MD5 hashes for any single file, a flat folder, or recursively for all files and folders. It can export its entire results package to a nominated .xml file. It can also conduct verification of file sets against a previously saved listing. It is used from a command prompt, but can be run using the Shell function from code like VBA, or from a batch file. For further reading in its use see: Availability and description of the File Checksum Integrity Verifier utility.
Making File Hash Listings
FCIV Hash Run at the Command Line
For completion, the command line code here will make an XML file of SHA1 hashes of the entire Documents folder. Omission of the xml term and the path that follows it will result in a screen listing. Notice the need for double quotes for paths that contain spaces.
The fciv utility is assumed here to reside in the FCIV folder.
c:\>FCIV\fciv.exe -r "C:\users\My Folder\Documents" -sha1 -xml "c:\users\My Folder\Documents\myhash.xml"
FCIV Hash Run from VBA
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 Also
- 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 Links
- 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
Summary
At times it is useful to write strings to a text file from VBA. For example, for listing files, their hashes, or for simply logging errors. Text files are here intended to mean files with the .txt suffix. There are several procedures listed in the code module for both writing and reading such files.
Writing to Text Files and Logs
- The procedure SendToLogFile APPENDS a string to a text file. The user optionally selects his own path and file name, but there is no OVERWRITE choice with this method. If user parameters are not given then the defaults are used. This procedure places the parameter string in line with a time date string, with each record entry on a new line.
- The procedure LogError1 is intended to APPEND log errors, and is an example of the Print# statement. It is assumed here that the log file will always be placed in the same folder as the calling Workbook. As such, no path check is needed, and the minimum of coding applies. All formatting of the parameter text is assumed to be done externally. Readers can find format details for Print# in VBA help, and might also care to compare the advantages of using the Write# statement instead.
- The procedure LogError2 is also intended to APPEND log errors and performs the same task as LogError1. It is however an example of the OpenTextFile method of the Scripting object. This procedure needs a reference in the VBA editor to Microsoft Scripting Runtime. Notice that this log will write every successive record into the first line unless vbNewLine characters are included at the end of the parameter string itself.
- Procedure WriteToFile REPLACES any existing text, as opposed to appending it to any existing entries.
- There are conventions in logging. Logging with a text file (.txt) means placing each record on the same line with the individual fields separated by a single tab character. The number of fields is the same for each record. Another convention is to use a comma-separated file format (.csv) where the fields are separated by commas instead of tabs. Both of these formats can be imported into MS Office applications,though users should pay particular attention as to how different log writing methods handle quotes.
Reading Text Files and Logs
- VBA can also read text files into code for processing. However, once the notion of reading files is introduced, the choice of writing formats becomes more important. In addition, file reading can place more demands on error handling, and testing for path integrity.
- The procedure GetAllFileText returns the entire contents of a .txt file . Readers should first confirm that the text file exists. File utilities elsewhere in this series would suit this purpose.
- The procedure GetLineText returns an array of text file lines. The same comments regarding early file checks also apply in this case.
VBA Code
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
Summary
This code block contains a message box function for YES, NO or CANCEL.
VBA Code
Option Explicit
Sub TestYesNoCancel()
'run to test message box
Dim bDefault As Boolean
If YesNoCancel(bDefault) = True Then
If bDefault Then
'do default stuff
MsgBox "Using default"
Else
'do other stuff
MsgBox "Using other"
End If
Else
'do cancelled stuff
MsgBox "User cancelled"
Exit Sub
End If
End Sub
Function YesNoCancel(bDefault As Boolean) As Boolean
'Message box for yes, no, or cancel
Dim Msg As String, Style As Long, Title As String
Dim Reply As Integer
'assignments
Msg = "Do you want the default ?" & vbNewLine & vbNewLine & _
"Select :" & vbNewLine & _
"YES ; for the default," & vbNewLine & _
"NO ; for some other," & vbNewLine & _
"CANCEL ; to quit." 'message
Style = vbYesNoCancel + vbQuestion + vbDefaultButton1 'buttons.
Title = "Yes, No, Cancel layout..." 'title.
'show message box
Reply = MsgBox(Msg, Style, Title)
'resolve choice
Select Case Reply
Case vbYes
bDefault = True
YesNoCancel = True
Case vbNo
YesNoCancel = True
Exit Function
Case vbCancel
Exit Function
End Select
End Function
See Also
External Links
Input Boxes
Summary
This code block contains an input box function. It includes a number of fairly common validation routines that are selected within the main procedure.
VBA Code
Option Explicit
Sub TestGetAnInput()
'run to test input box functions
Dim vR As Variant, bC As Boolean
If GetAnInput(vR, bC) Then
MsgBox vR
ElseIf bC = True Then MsgBox "Cancel or too many attempts"
Else
MsgBox "Input must be an integer"
End If
End Sub
Function GetAnInput(vRet As Variant, bCancel As Boolean) As Boolean
'================================================================================
'Input box function - gets an input from user with choice of validation, or none.
'Returns value in vRet and funcion True, or bCancel = true and function False.
'With bUseValidation = True, loops until success, cancel, or 3 failed attempts.
'With bUseValidation = False, returns first entry without validation.
'Enable chosen validation function below.
'================================================================================
Dim Reply As Variant, bValidated As Boolean, n As Long, bUseValidation As Boolean
Dim sMsg As String, sTitle As String, sDefault As String
Dim nS As Integer, nE As Integer
'set assignments
sMsg = "Enter an integer..."
sTitle = "Input box..."
sDefault = "1234567890"
n = 1
nS = 32: nE = 126 'printing chara set 32-126
bUseValidation = False 'use validation at all?
Do 'get user input
Reply = InputBox(sMsg, sTitle, sDefault)
'test if validation needed
If bUseValidation = False Then
bValidated = True
Exit Do
End If
'control number of attempts
If n >= 3 Then 'set attempt limit here
Exit Do
End If
n = n + 1
'add validation by removing comment on one function call
' ========================================================
' ENABLE ONLY ONE VALIDATION FUNCTION
' ========================================================
' If IsNumeric(Reply) Then bValidated = True
' If IsAnInteger(Reply) Then bValidated = True
' If IsADate(Reply) Then bValidated = True
' If IsLikeCustomFormat(Reply) Then bValidated = True
' If IncludesAscRange(Reply, nS, nE) Then bValidated = True
' If ExcludesAscRange(Reply, nS, nE) Then bValidated = True
' If IsAllInAscRange(Reply, nS, nE) Then bValidated = True
'=========================================================
Loop Until bValidated = True Or Reply = ""
'transfers
If bValidated Then
vRet = Reply 'got one
GetAnInput = True
ElseIf Reply = "" Then 'cancelled
bCancel = True
Else 'too many tries
bCancel = True
End If
End Function
Function IsAnInteger(ByVal vIn As Variant) As Boolean
'returns true if input contains an integer
'check if numeric
'numeric excludes dates and booleans
If IsNumeric(vIn) Then
'check long version against original
If vIn = CLng(vIn) Then
IsAnInteger = True
End If
End If
End Function
Function IsADate(ByVal vIn As Variant) As Boolean
'returns true if input contains a date
'check if date
If IsDate(vIn) Then
IsADate = True
End If
End Function
Function IsAllInAscRange(ByVal vIn As Variant, nS As Integer, _
nE As Integer) As Boolean
'returns true if entire string lies in asci parameter range
Dim n As Long, sS As String, sAccum As String
'check vIn
If CStr(vIn) = "" Then
Exit Function
End If
'================================================================
' Character Set (0-127) ASCI Values Assignments
'================================================================
'48 To 57 'integers 0-9
'65 To 90 'capital letters A-Z
'97 To 122 'lower case letters a-z
'33 To 47, 58 To 64,91 To 96, 123 To 126 'printing symbols
'0 To 7, 11 To 12, 14 To 31, 127 'not Windows supported
'32 'space character
'8, 9, 10, 13 'vbBack,vbTab,vbLf,vbCr
'=================================================================
'accumulate all validated charas
For n = 1 To Len(vIn)
sS = Mid(CStr(vIn), n, 1)
Select Case Asc(sS)
Case nS To nE 'parameters
sAccum = sAccum & sS
End Select
Next n
If Len(sAccum) = Len(vIn) Then
IsAllInAscRange = True
End If
End Function
Function IncludesAscRange(ByVal vIn As Variant, nS As Integer, _
nE As Integer) As Boolean
'returns true if any part of string lies in asci parameter range
Dim n As Long, sS As String
'check vIn
If CStr(vIn) = "" Then
Exit Function
End If
'================================================================
' Character Set (0-127) ASCI Values Assignments
'================================================================
'48 To 57 'integers 0-9
'65 To 90 'capital letters A-Z
'97 To 122 'lower case letters a-z
'33 To 47, 58 To 64,91 To 96, 123 To 126 'printing symbols
'0 To 7, 11 To 12, 14 To 31, 127 'not Windows supported
'32 'space character
'8, 9, 10, 13 'vbBack,vbTab,vbLf,vbCr
'=================================================================
'early exit for first inclusion found
For n = 1 To Len(vIn)
sS = Mid(CStr(vIn), n, 1)
Select Case Asc(sS)
Case nS To nE 'parameters
'found - so exit
IncludesAscRange = True
Exit Function
End Select
Next n
End Function
Function ExcludesAscRange(ByVal vIn As Variant, nS As Integer, _
nE As Integer) As Boolean
'returns true if input does not contain any part of asci parameter range
Dim n As Long, sS As String, sAccum As String
'check vIn
If CStr(vIn) = "" Then
Exit Function
End If
'================================================================
' Character Set (0-127) ASCI Values Assignments
'================================================================
'48 To 57 'integers 0-9
'65 To 90 'capital letters A-Z
'97 To 122 'lower case letters a-z
'33 To 47, 58 To 64,91 To 96, 123 To 126 'printing symbols
'0 To 7, 11 To 12, 14 To 31, 127 'not Windows supported
'32 'space character
'8, 9, 10, 13 'vbBack,vbTab,vbLf,vbCr
'=================================================================
'early exit for first inclusion found
For n = 1 To Len(vIn)
sS = Mid(CStr(vIn), n, 1)
Select Case Asc(sS)
Case nS To nE 'parameters
'found - so exit
sAccum = sAccum & sS
End Select
Next n
If sAccum = "" Then
ExcludesAscRange = True
End If
End Function
Function IsLikeCustomFormat(ByVal vIn As Variant) As Boolean
'returns true if input pattern is like internal pattern
Dim sPattern As String
'check vIn
If CStr(vIn) = "" Then
Exit Function
End If
'specify the pattern - see help for Like operator
sPattern = "CAT###-[a-z][a-z]#" 'for example CAT123-fg7
'test the pattern against input
IsLikeCustomFormat = vIn Like sPattern
End Function
See Also
External Links
Pseudo Random Repeated Substrings
Summary
This page describes some matters that apply to the Rnd() function of VBA. In particular it illustrates that repeated substrings can result when the Randomize() function is wrongly positioned inside the same loop as Rnd(), instead of before it.
The VBA Rnd() Function
- 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?
- 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
Summary
- 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() algorithm
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 = 16598013
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)
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 PRNGs
The code module below contains a stripped down version of the Wichmann-Hill (1982) algorithm, in fact using only the first of its three calculated sections. It will make several complete streams of values on Sheet1 of the workbook in which it is run, using different start values. Notice that the first values are all repeated at row 30269, as will the whole stream if extended. After producing the list, use the spreadsheet's functions for column sorting and the removal of duplicates to see that each column contains the appropriate number of unique entries. An even simpler generator with a repeat cycle of just 43 is also included that might make study more manageable, and the cycle of Microsoft's Rnd() can be seen to repeat at 16777216 (+1) by running TestMSRnd.
The code in this section should be saved as a separate standard module in Excel.
Option Explicit
Private ix2 As Long
Sub TestWHRnd30269()
'makes five columns for complete output streams
'each with a different start point
'runs a simplified LCNG with mod 30269
Dim sht As Worksheet, nS As Double, nSamp As Long
Dim c As Long, r As Long, nSeed As Long
'set seed value for Rnd2()
nSeed = 327680 'WH initial seed
'set number of random samples to make
nSamp = 30275 '30269 plus say, 6
'set initial value of carry variable
ix2 = nSeed
Set sht = ThisWorkbook.Worksheets("Sheet1")
'clear the worksheet
sht.Cells.Cells.ClearContents
'load sheet with set of samples
For c = 1 To 5 'number of runs
ix2 = nSeed + c 'change start value
For r = 1 To nSamp 'number of samples
nS = WHRnd30269() 'get a sample
sht.Cells(r, c) = nS 'write to sheet
Next r
Next c
sht.Cells(1, 1).Select
End Sub
Function WHRnd30269() As Double
'first part of Wichmann-Hill tripple.
'When started with seed ix2 = 171,
'full sequence repeats from n = 30269
'without any repeated values before.
Dim r As Double
'ix2 cannot be 0.
If ix2 = 0 Then
ix2 = 171
End If
'calculate Xn+1 from Xn
ix2 = (171 * ix2) Mod 30269
'make an output value
r = ix2 / 30269#
WHRnd30269 = r - Int(r)
End Function
Sub TestSimpleRnd43()
'makes five columns for complete output streams
'each with a different start point
'runs a very simple LCNG with mod 43
Dim sht As Worksheet, nS As Double, nSamp As Long
Dim c As Long, r As Long, nSeed As Long
'set seed value for Rnd2()
nSeed = 17 'initial seed
'set number of random samples to make
nSamp = 45 '43 plus say, 2
'set initial value of carry variable
ix2 = nSeed
Set sht = ThisWorkbook.Worksheets("Sheet1")
'clear the worksheet
sht.Cells.Cells.ClearContents
'load sheet with set of samples
For c = 1 To 5 'number of runs
ix2 = nSeed + c 'change start value
For r = 1 To nSamp 'number of samples
nS = SimpleRnd43() 'get a sample
sht.Cells(r, c) = nS 'write to sheet
Next r
Next c
sht.Cells(1, 1).Select
End Sub
Function SimpleRnd43() As Double
'simple Lehmer style LCNG to show repeat streams
'produces one sequence of 42 unique values - then repeats entire sequence
'start value decides only where the predictable sequence begins
Dim r As Double
'Note; Makes 42 unique values before sequence repeats
'Modulus = 43: Multiplier = 5: Initial Seed = 17
'43 is prime
'5 is primitive root mod 43
'17 is coprime to 43
'ix2 cannot be 0.
If ix2 = 0 Then
ix2 = 17
End If
'calculate a new carry variable
ix2 = (5 * ix2) Mod 43
'make an output value
r = ix2 / 43#
SimpleRnd43 = r - Int(r)
End Function
Sub TestMSRnd()
'makes two sets of single data using MS Rnd
'the first 10 samples of Rnd() values
'followed by values around sample 16777216
'confirms sequence probably re-starts at M+1 = 16777217
Dim sht As Worksheet, nS As Double
Dim c As Long, r As Long, nMod As Long
'note modulus
nMod = 16777216
Set sht = ThisWorkbook.Worksheets("Sheet1")
'clear the worksheet
sht.Cells.Cells.ClearContents
'load sheet with set of samples
For r = 1 To nMod + 20 'number of samples
nS = Rnd() 'get a sample
Select Case r
Case 1 To 10
sht.Cells(r, 1) = r
sht.Cells(r, 2) = nS
Case (nMod - 4) To (nMod + 5)
sht.Cells(r - 16777211 + 10, 1) = r
sht.Cells(r - 16777211 + 10, 2) = nS
End Select
Next r
sht.Cells(1, 1).Select
End Sub
References
- Wichmann, Brian; Hill, David (1982), Algorithm AS183: An Efficient and Portable Pseudo-Random Number Generator, Journal of the Royal Statistical Society. Series C
See Also
- 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 Links
- How Visual Basic Generates Pseudo-Random Numbers for the RND Function: Microsoft kb231847 knowledge base item
A Pseudo Random Character Table
Summary
This code module is intended for MS Excel. It makes a pseudo random table of characters, integers and capitals in this case, on Sheet1. A new and different table is made each time the procedure is run.
The Table
- Copy the code into a standard VBA module in Excel, and run the procedure MakePseudoRandomTable() to make a table. As shown, Sheet1 will be overwritten.
- The output uses a monospaced font, Consolas, for the clearest layout and type. In addition to ensuring a neat layout vertically and horizontally, monospaced tables allow the reading of sequences on a diagonal, so greatly extend their usefulness.
- Adjust the size of the table by changing the values nRows, and nCols in the code heading, and if necessary insert the name of the sheet to use. The code will add numbered row and column headings and will add these to each page that is displayed or printed.
- If an exact number of columns and rows is needed, adjust the margins for the sheet, and perhaps the font size until the required result is obtained.
- The proportion of integers to capitals is just 10/36, but is easily changed in code with a little effort.
The VBA Code Module
Option Explicit
Sub MakePseudoRandomTable()
' Makes a pseudo random table of integers and capitals
' using VBA internal function Rnd().
'NOTES
' User should set narrow margins for best use of page.
' This will give about 47 rows by 35 cols
' Numbered headings are set to repeat on each printed page.
' Set number of rows and columns below.
' Integers to capitals ratio approx 10:26 = 0.385.
' Enter "0-127" in VBA Help for link to ASCI code numbers.
Dim sht As Worksheet, sStr As String
Dim nX As Integer, nAsc As Integer
Dim nRows As Long, nCols As Long
Dim nR As Long, nC As Long
'set required table size and worksheet name here
nRows = 100 'number of rows
nCols = 100 'number of columns
Set sht = ThisWorkbook.Worksheets("Sheet1")
sht.Activate
'clear and format worksheet
With sht.Columns
.ClearContents
.ClearFormats
.HorizontalAlignment = xlCenter
.Font.Name = "Consolas" 'monospaced
.Font.Size = 12
.ColumnWidth = 2
End With
Randomize Timer 'seed system timer
For nR = 1 To nRows 'row loop
For nC = 1 To nCols 'col loop
'allow break commands
DoEvents
'choose integer between 1 and 36 (total number of characters)
nX = Int((36 - 1 + 1) * Rnd + 1)
'make asci numbers in a decided proportion
'set nX<=18 And nX>=1 here for equal integers and capitals
If nX <= 10 And nX >= 1 Then 'for 10:26
nAsc = Int((57 - 48 + 1) * Rnd + 48) 'integers 48 to 57
Else
nAsc = Int((90 - 65 + 1) * Rnd + 65) 'capitals 65 to 90
End If
'convert asci number to string
sStr = Chr(nAsc)
'print single string character per cell
sht.Cells(nR, nC).Value = sStr
Next nC
Next nR
'add numbers to column headings
For nC = 1 To nCols
sht.Cells(1, nC) = nC
Next nC
'set size and orientation of column headings
With sht.Rows(1)
.Font.Size = 12
.Orientation = 90 'vertical
End With
'add numbers to row headings
For nR = 1 To nRows
sht.Cells(nR, 1) = nR
Next nR
'set size of row headings
With sht.Columns(1)
.Font.Size = 12
End With
'print row and col headings on every page
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = "$A:$A"
End With
Application.PrintCommunication = True
'select first cell
sht.Cells(1, 1).Select
End Sub
See Also
External Links
Listing Prime Numbers
Summary
.
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 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 Notes
The Code Module
Option Explicit
Sub testListPrimes()
'Run this to list primes in range of
'unity to some integer value
Dim nNum As Long
'set upper limit of range here
'eg:1234567 gives 95360 primes from 2 to 1234547 in 3 minutes
nNum = 1234567
'MsgBox ListPrimes(nNum)
ListPrimes nNum
End Sub
Function ListPrimes(nInput As Long) As String
'Lists primes in range unity to nInput
'Output to Sheet1 and function name
'Method: Sieve of Eratosthenes
Dim arr() As Long, oSht As Worksheet, sOut As String
Dim a As Long, b As Long, c As Long, s As Long
Dim nRow As Long, nCol As Long
'dimension array
ReDim arr(1 To nInput)
'set reference to Sheet1
Set oSht = ThisWorkbook.Worksheets("Sheet1")
With oSht
.Activate
.Cells.ClearContents
End With
'fill work array with integers
If nInput > 1 Then
arr(1) = 0 'exception first element
For a = 2 To nInput
arr(a) = a
Next a
Else
MsgBox "Needs parameter greater than unity - closing"
Exit Function
End If
'Sieve of Eratosthenes
'progressively eliminate prime multiples
For b = 2 To nInput
DoEvents 'yield
If arr(b) <> 0 Then 'skip zeroed items
'replace prime multiples with zero
s = 2 * b
Do Until s > nInput
DoEvents 'yield
arr(s) = 0
s = s + b
Loop
End If
Next b
'Output of primes
sOut = "Primes in range 1 to " & nInput & ":" & vbCrLf
nRow = 1: nCol = 1
For c = 2 To nInput
If arr(c) <> 0 Then
oSht.Cells(nRow, nCol) = c 'primes list to Sheet1
nRow = nRow + 1
If c <> nInput Then 'and accumulate a string
sOut = sOut & c & ","
Else
sOut = sOut & c
End If
End If
Next c
ListPrimes = sOut
End Function
Sub testGetPrimeFactors()
'Run this for prime factors of integer
'Set integer as a string in sIn to avoid display truncation
'Decimal subtype applies and limited to 28 full digits.
Dim nIn, sIn As String, Reply, sOut As String, sT As String
'set integer to factorise here, as a string
sIn = "9999999999999999999999999999" '28 nines takes 15 seconds
nIn = CDec(sIn)
sOut = GetPrimeFactors(nIn)
MsgBox sOut & vbCrLf & _
"Input digits length : " & Len(sIn)
'optional inputbox allows copy of output
Reply = InputBox("Factors of" & nIn, , sOut)
End Sub
Function DecMod(Dividend As Variant, Divisor As Variant) As Variant
' Declare two double precision variables
Dim D1 As Variant, D2 As Variant
D1 = CDec(Dividend)
D2 = CDec(Divisor)
'return remainder after division
DecMod = D1 - (Int(D1 / D2) * D2)
End Function
Function GetPrimeFactors(ByVal nN As Variant) As String
'Returns prime factors of nN in parameter
'Maximum of 28 digits full digits for decimal subtype input.
'Completion times vary greatly - faster for more primes
'20,21,and 22 nines factorise immediately, 23 nines time excessive.
'25 nines in 6 seconds. Maximum input takes 15 seconds for 28 nines.
Dim nP As Variant, sAcc As String
nP = CDec(nP)
nP = 2
nN = CDec(nN)
sAcc = nN & " = "
'test successive factors
Do While nN >= nP * nP
DoEvents
If DecMod(nN, nP) = 0 Then
sAcc = sAcc & nP & " * "
nN = nN / nP '(divide by prime)
Else
nP = nP + 1
End If
Loop
'output results
GetPrimeFactors = sAcc & CStr(nN)
End Function
See Also
Big Number Arithmetic with Strings
Summary
- This VBA module is intended for Microsoft Excel but can run with minor changes in any of the MS Office applications with a VBA editor.
- The data types of VBA prevent big number calculations. That is to say, beyond twenty or thirty digits, and even then much care is needed to avoid overflow. Strings have few such restrictions, being limited in most cases to the size of the memory space of the application.
- The code module below includes most of the basic arithmetic functions without any size restriction.
- The work is not by this author, but credit should be given to Rebecca Gabriella's String Math Module notes at Big Integer Library. This author has made only cosmetic changes to the work, and added a test procedure to illustrate its use.
Code Notes
- The module includes functions for the following: Addition, subtraction, multiplication, and division, all using integer strings. Also included are conversion functions to restore base10 from some other base, and to produce a new base from some existing base10 input. Other support functions such as RealMod() are also included.
- No output code to the sheet has been provided. Owing to Excel's habit of truncating numbers, even if they are strings, users who want to use the worksheet should concatenate an apostrophe before the display string to prevent this happening. The apostrophe will not be displayed. It is unclear how else this device affects the subsequent use of the numbers.
- A remainder after division is produced. It can be found as sLastRemainder, and is public.
- Users who install code in MS Access should change the Option Compare Text to Option Compare DataBase. The former is intended for MS Excel.
The VBA String Math Module
Option Explicit
Option Compare Text 'Database for Access
'--------------------------------------------------------------------------------------------------------------
'https://cosxoverx.livejournal.com/47220.html
'Credit to Rebecca Gabriella's String Math Module (Big Integer Library) for VBA (Visual Basic for Applications)
' Minor edits made with comments and other.
'--------------------------------------------------------------------------------------------------------------
Public Type PartialDivideInfo
Quotient As Integer
Subtrahend As String
Remainder As String
End Type
Public sLastRemainder As String
Private Const Alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Private Sub TestMultAndDiv()
'Run this to test multiplication and division with integer strings
'Open immediate window in View or with ctrl-g to see results
Dim sP1 As String, sP2 As String, sRes1 As String, sRes2 As String
sP1 = "6864797660130609714981900799081393217269" & _
"4353001433054093944634591855431833976560" & _
"5212255964066145455497729631139148085803" & _
"7121987999716643812574028291115057151" '157 digits and prime
sP2 = "162259276829213363391578010288127" '33 digits and also prime
'multiply these two as integer strings
sRes1 = Multiply(sP1, sP2)
Debug.Print sP1
Debug.Print "Length of 1st number : " & Len(sP1)
Debug.Print sP2
Debug.Print "Length of 2nd number : " & Len(sP2)
Debug.Print "Product : " & sRes1
Debug.Print "Length of product : " & Len(sRes1)
Debug.Print " "
'then divide the product by sP1 obtains sP2 again
sRes2 = Divide(sRes1, sP1)
Debug.Print sRes1
Debug.Print "Length of 1st number : " & Len(sRes1)
Debug.Print sP1
Debug.Print "Length of 2nd number : " & Len(sP1)
Debug.Print "Integer Quotient : " & sRes2
Debug.Print "Length of quotient : " & Len(sRes2)
Debug.Print "Remainder after integer division : " & sLastRemainder
Debug.Print " "
'Notes:
'Clear immediate window with ctrl-g, then ctrl-a, then delete
'If sending long integer strings to the worksheet, prefix with apostrophe before output
'or it will be truncated by Excel. Needs consideration also on pickup from sheet.
'Alternatively use a textbox in a userform for error free display. Ctrl-C to copy out.
End Sub
Private Function Compare(ByVal sA As String, ByVal sB As String) As Integer
'Parameters are string integers of any length, for example "-345...", "973..."
'Returns an integer that represents one of three states
'sA > sB returns 1, sA < sB returns -1, and sA = sB returns 0
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
Dim i As Integer, iA As Integer, iB As Integer
'handle any early exits on basis of signs
bAN = (Left(sA, 1) = "-")
bBN = (Left(sB, 1) = "-")
If bAN Then sA = Mid(sA, 2)
If bBN Then sB = Mid(sB, 2)
If bAN And bBN Then
bRN = True
ElseIf bBN Then
Compare = 1
Exit Function
ElseIf bAN Then
Compare = -1
Exit Function
Else
bRN = False
End If
'remove any leading zeros
Do While Len(sA) > 1 And Left(sA, 1) = "0"
sA = Mid(sA, 2) 'starting at pos 2
Loop
Do While Len(sB) > 1 And Left(sB, 1) = "0"
sB = Mid(sB, 2) 'starting at pos 2
Loop
'then decide size first on basis of length
If Len(sA) < Len(sB) Then
Compare = -1
ElseIf Len(sA) > Len(sB) Then
Compare = 1
Else 'unless they are the same length
Compare = 0
'then check each digit by digit
For i = 1 To Len(sA)
iA = CInt(Mid(sA, i, 1))
iB = CInt(Mid(sB, i, 1))
If iA < iB Then
Compare = -1
Exit For
ElseIf iA > iB Then
Compare = 1
Exit For
Else 'defaults zero
End If
Next i
End If
'decide about any negative signs
If bRN Then
Compare = -Compare
End If
End Function
Public Function Add(ByVal sA As String, ByVal sB As String) As String
'Parameters are string integers of any length, for example "-345...", "973..."
'Returns sum of sA and sB as string integer in Add()
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
Dim iA As Integer, iB As Integer, iCarry As Integer
'test for empty parameters
If Len(sA) = 0 Or Len(sB) = 0 Then
MsgBox "Empty parameter in Add()"
Exit Function
End If
'handle some negative values with Subtract()
bAN = (Left(sA, 1) = "-")
bBN = (Left(sB, 1) = "-")
If bAN Then sA = Mid(sA, 2)
If bBN Then sB = Mid(sB, 2)
If bAN And bBN Then 'both negative
bRN = True 'set output reminder
ElseIf bBN Then 'use subtraction
Add = Subtract(sA, sB)
Exit Function
ElseIf bAN Then 'use subtraction
Add = Subtract(sB, sA)
Exit Function
Else
bRN = False
End If
'add column by column
iA = Len(sA)
iB = Len(sB)
iCarry = 0
Add = ""
Do While iA > 0 And iB > 0
iCarry = iCarry + CInt(Mid(sA, iA, 1)) + CInt(Mid(sB, iB, 1))
Add = CStr(iCarry Mod 10) + Add
iCarry = iCarry \ 10
iA = iA - 1
iB = iB - 1
Loop
'Assuming param sA is longer
Do While iA > 0
iCarry = iCarry + CInt(Mid(sA, iA, 1))
Add = CStr(iCarry Mod 10) + Add
iCarry = iCarry \ 10
iA = iA - 1
Loop
'Assuming param sB is longer
Do While iB > 0
iCarry = iCarry + CInt(Mid(sB, iB, 1))
Add = CStr(iCarry Mod 10) + Add
iCarry = iCarry \ 10
iB = iB - 1
Loop
Add = CStr(iCarry) + Add
'remove any leading zeros
Do While Len(Add) > 1 And Left(Add, 1) = "0"
Add = Mid(Add, 2)
Loop
'decide about any negative signs
If Add <> "0" And bRN Then
Add = "-" + Add
End If
End Function
Private Function RealMod(ByVal iA As Integer, ByVal iB As Integer) As Integer
'Returns iA mod iB in RealMod() as an integer. Good for small values.
'Normally Mod takes on the sign of iA but here
'negative values are increased by iB until result is positive.
'Credit to Rebecca Gabriella's String Math Module with added edits.
'https://cosxoverx.livejournal.com/47220.html
If iB = 0 Then
MsgBox "Divide by zero in RealMod()"
Exit Function
End If
If iA Mod iB = 0 Then
RealMod = 0
ElseIf iA < 0 Then
RealMod = iB + iA Mod iB 'increase till pos
Else
RealMod = iA Mod iB
End If
End Function
Private Function RealDiv(ByVal iA As Integer, ByVal iB As Integer) As Integer
'Returns integer division iA divided by iB in RealDiv().Good for small values.
'Credit to Rebecca Gabriella's String Math Module with added edits.
'https://cosxoverx.livejournal.com/47220.html
If iB = 0 Then
MsgBox "Divide by zero in RealDiv()"
Exit Function
End If
If iA Mod iB = 0 Then
RealDiv = iA \ iB
ElseIf iA < 0 Then
RealDiv = iA \ iB - 1 'round down
Else
RealDiv = iA \ iB
End If
End Function
Public Function Subtract(ByVal sA As String, ByVal sB As String) As String
'Parameters are string integers of any length, for example "-345...", "973..."
'Returns sA minus sB as string integer in Subtract()
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
Dim iA As Integer, iB As Integer, iComp As Integer
'test for empty parameters
If Len(sA) = 0 Or Len(sB) = 0 Then
MsgBox "Empty parameter in Subtract()"
Exit Function
End If
'handle some negative values with Add()
bAN = (Left(sA, 1) = "-")
bBN = (Left(sB, 1) = "-")
If bAN Then sA = Mid(sA, 2)
If bBN Then sB = Mid(sB, 2)
If bAN And bBN Then
bRN = True
ElseIf bBN Then
Subtract = Add(sA, sB)
Exit Function
ElseIf bAN Then
Subtract = "-" + Add(sA, sB)
Exit Function
Else
bRN = False
End If
'get biggest value into variable sA
iComp = Compare(sA, sB)
If iComp = 0 Then 'parameters equal in size
Subtract = "0"
Exit Function
ElseIf iComp < 0 Then 'sA < sB
Subtract = sA 'so swop sA and sB
sA = sB 'to ensure sA >= sB
sB = Subtract
bRN = Not bRN 'and reverse output sign
End If
iA = Len(sA) 'recheck lengths
iB = Len(sB)
iComp = 0
Subtract = ""
'subtract column by column
Do While iA > 0 And iB > 0
iComp = iComp + CInt(Mid(sA, iA, 1)) - CInt(Mid(sB, iB, 1))
Subtract = CStr(RealMod(iComp, 10)) + Subtract
iComp = RealDiv(iComp, 10)
iA = iA - 1
iB = iB - 1
Loop
'then assuming param sA is longer
Do While iA > 0
iComp = iComp + CInt(Mid(sA, iA, 1))
Subtract = CStr(RealMod(iComp, 10)) + Subtract
iComp = RealDiv(iComp, 10)
iA = iA - 1
Loop
'remove any leading zeros from result
Do While Len(Subtract) > 1 And Left(Subtract, 1) = "0"
Subtract = Mid(Subtract, 2)
Loop
'decide about any negative signs
If Subtract <> "0" And bRN Then
Subtract = "-" + Subtract
End If
End Function
Public Function Multiply(ByVal sA As String, ByVal sB As String) As String
'Parameters are string integers of any length, for example "-345...", "973..."
'Returns sA times sB as string integer in Multiply()
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
Dim m() As Long, iCarry As Long
Dim iAL As Integer, iBL As Integer, iA As Integer, iB As Integer
'test for empty parameters
If Len(sA) = 0 Or Len(sB) = 0 Then
MsgBox "Empty parameter in Multiply()"
Exit Function
End If
'handle any negative signs
bAN = (Left(sA, 1) = "-")
bBN = (Left(sB, 1) = "-")
If bAN Then sA = Mid(sA, 2)
If bBN Then sB = Mid(sB, 2)
bRN = (bAN <> bBN)
iAL = Len(sA)
iBL = Len(sB)
'perform long multiplication without carry in notional columns
ReDim m(1 To (iAL + iBL - 1)) 'expected length of product
For iA = 1 To iAL
For iB = 1 To iBL
m(iA + iB - 1) = m(iA + iB - 1) + CLng(Mid(sA, iAL - iA + 1, 1)) * CLng(Mid(sB, iBL - iB + 1, 1))
Next iB
Next iA
iCarry = 0
Multiply = ""
'add up column results with carry
For iA = 1 To iAL + iBL - 1
iCarry = iCarry + m(iA)
Multiply = CStr(iCarry Mod 10) + Multiply
iCarry = iCarry \ 10
Next iA
Multiply = CStr(iCarry) + Multiply
'remove any leading zeros
Do While Len(Multiply) > 1 And Left(Multiply, 1) = "0"
Multiply = Mid(Multiply, 2)
Loop
'decide about any negative signs
If Multiply <> "0" And bRN Then
Multiply = "-" + Multiply
End If
End Function
Public Function PartialDivide(ByVal sA As String, ByVal sB As String) As PartialDivideInfo
'Called only by Divide() to assist in fitting trials for long division
'All of Quotient, Subtrahend, and Remainder are returned as elements of type PartialDivideInfo
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
For PartialDivide.Quotient = 9 To 1 Step -1 'propose a divisor to fit
PartialDivide.Subtrahend = Multiply(sB, CStr(PartialDivide.Quotient)) 'test by multiplying it out
If Compare(PartialDivide.Subtrahend, sA) <= 0 Then 'best fit found
PartialDivide.Remainder = Subtract(sA, PartialDivide.Subtrahend) 'get remainder
Exit Function 'exit with best fit details
End If
Next PartialDivide.Quotient
'no fit found, divisor too big
PartialDivide.Quotient = 0
PartialDivide.Subtrahend = "0"
PartialDivide.Remainder = sA
End Function
Public Function Divide(ByVal sA As String, ByVal sB As String) As String
'Parameters are string integers of any length, for example "-345...", "973..."
'Returns sA divided by sB as string integer in Divide()
'The remainder is available as sLastRemainder at Module level
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bAN As Boolean, bBN As Boolean, bRN As Boolean
Dim iC As Integer
Dim s As String
Dim d As PartialDivideInfo
'test for empty parameters
If Len(sA) = 0 Or Len(sB) = 0 Then
MsgBox "Empty parameter in Divide()"
Exit Function
End If
bAN = (Left(sA, 1) = "-") 'true for neg
bBN = (Left(sB, 1) = "-")
If bAN Then sA = Mid(sA, 2) 'take two charas if neg
If bBN Then sB = Mid(sB, 2)
bRN = (bAN <> bBN)
If Compare(sB, "0") = 0 Then
Err.Raise 11
Exit Function
ElseIf Compare(sA, "0") = 0 Then
Divide = "0"
sLastRemainder = "0"
Exit Function
End If
iC = Compare(sA, sB)
If iC < 0 Then
Divide = "0"
sLastRemainder = sA
Exit Function
ElseIf iC = 0 Then
If bRN Then
Divide = "-1"
Else
Divide = "1"
End If
sLastRemainder = "0"
Exit Function
End If
Divide = ""
s = ""
'Long division method
For iC = 1 To Len(sA)
'take increasing number of digits
s = s + Mid(sA, iC, 1)
d = PartialDivide(s, sB) 'find best fit
Divide = Divide + CStr(d.Quotient)
s = d.Remainder
Next iC
'remove any leading zeros
Do While Len(Divide) > 1 And Left(Divide, 1) = "0"
Divide = Mid(Divide, 2)
Loop
'decide about the signs
If Divide <> "0" And bRN Then
Divide = "-" + Divide
End If
sLastRemainder = s 'string integer remainder
End Function
Public Function LastModulus() As String
LastModulus = sLastRemainder
End Function
Public Function Modulus(ByVal sA As String, ByVal sB As String) As String
Divide sA, sB
Modulus = sLastRemainder
End Function
Public Function BigIntFromString(ByVal sIn As String, ByVal iBaseIn As Integer) As String
'Returns base10 integer string from sIn of different base (iBaseIn).
'Example for sIn = "1A" and iBaseIn = 16, returns the base10 result 26.
'Credit to Rebecca Gabriella's String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bRN As Boolean
Dim sBS As String
Dim iP As Integer, iV As Integer
'test for empty parameters
If Len(sIn) = 0 Or iBaseIn = 0 Then
MsgBox "Bad parameter in BigIntFromString()"
Exit Function
End If
'handle negative signs
If Left(sIn, 1) = "-" Then
bRN = True
sIn = Mid(sIn, 2)
Else
bRN = False
End If
sBS = CStr(iBaseIn)
BigIntFromString = "0"
For iP = 1 To Len(sIn)
'use constant list position and base for conversion
iV = InStr(Alphabet, UCase(Mid(sIn, iP, 1)))
If iV > 0 Then 'accumulate
BigIntFromString = Multiply(BigIntFromString, sBS)
BigIntFromString = Add(BigIntFromString, CStr(iV - 1))
End If
Next iP
'decide on any negative signs
If bRN Then
BigIntFromString = "-" + BigIntFromString
End If
End Function
Public Function BigIntToString(ByVal sIn As String, ByVal iBaseOut As Integer) As String
'Returns integer string of specified iBaseOut (iBaseOut) from base10 (sIn) integer string.
'Example for sIn = "26" and iBaseOut = 16, returns the output "1A".
'Credit to Rebecca Gabriella'sIn String Math Module with added edits
'https://cosxoverx.livejournal.com/47220.html
Dim bRN As Boolean
Dim sB As String
Dim iV As Integer
'test for empty parameters
If Len(sIn) = 0 Or iBaseOut = 0 Then
MsgBox "Bad parameter in BigIntToString()"
Exit Function
End If
'handle negative signs
If Left(sIn, 1) = "-" Then
bRN = True
sIn = Mid(sIn, 2)
Else
bRN = False
End If
sB = CStr(iBaseOut)
BigIntToString = ""
Do While Compare(sIn, "0") > 0
sIn = Divide(sIn, sB)
iV = CInt(LastModulus())
'locates appropriate alphabet character
BigIntToString = Mid(Alphabet, iV + 1, 1) + BigIntToString
Loop
'decide on any negative signs
If BigIntToString = "" Then
BigIntToString = "0"
ElseIf BigIntToString <> "0" And bRN Then
BigIntToString = "-" + BigIntToString
End If
End Function
Added Big Math Fuctions
- Factorial() makes use of Multiply() and other integer math functions of the main module. It is of course fairly slow but is not otherwise limited in any practical way. The code has been arbitrarily limited to calculating values up to 1000!, but this can be adjusted by the user. DoEvents is important here, since it allows breaking the run if an unwise attempt is made. Reciprocal factorials and negative factorials are not handled here.
- IntStrByExp() raises integer strings to an exponent. Again, negative exponents cannot yet be handled in this procedure, though the number to raise can take a negative value.
Sub testFactorial()
'Run this to test factorial
Dim sIn As Integer, sOut As String
sIn = "400"
sOut = Factorial(sIn)
'output Immediate Window
Debug.Print sIn & "!" & vbCrLf & _
sOut & vbCrLf & _
Len(sOut) & " digits" & vbCrLf
'output message box - short output
'MsgBox sIn & "!" & vbcrlf & _
sOut & vbCrLf & _
Len(sOut) & " digits" & vbCrLf
End Sub
Function Factorial(ByVal sA As String) As String
'Returns integer string factorial for integer string parameter sA
'2000! in 30 secs (5736 digits); 1000! in six seconds (2568 digits)
'400! in one second (869 digits);100! pdq (158 digits).
'Arbitrarily set max sA = "1000"
Dim iC As Integer
'avoid excessively long runs
If CInt(sA) >= 1000 Then
MsgBox "Run time too long - closing."
Factorial = "Error - Run time too long"
Exit Function
End If
iC = CInt(sA)
Factorial = "1"
'run factorial loop
Do Until iC <= 0
DoEvents 'permits break key use
Factorial = Multiply(Factorial, iC)
iC = iC - 1
Loop
End Function
Sub testIntStrByExp()
'Run this to test IntStrByExp
Dim sIn As String, sOut As String, iExp As Integer, bA As Boolean
Dim nL As Integer
sIn = "-123456789123456789"
iExp = 7
sOut = IntStrByExp(sIn, iExp)
nL = Len(sOut)
If Left(sOut, 1) = "-" Then
nL = nL - 1
End If
'output Immediate Window
Debug.Print sIn & "^" & iExp & " equals" & vbCrLf & _
sOut & vbCrLf & _
nL & " digits out" & vbCrLf
'output message box - short output
MsgBox sIn & "^" & iExp & " equals" & vbCrLf & _
sOut & vbCrLf & _
nL & " digits out" & vbCrLf
End Sub
Function IntStrByExp(ByVal sA As String, ByVal iExp As Integer) As String
'Returns integer string raised to exponent iExp as integer string
'Assumes posiive exponent, and pos or neg string integer
Dim bA As Boolean, bR As Boolean
'check parameter
If iExp < 0 Then
MsgBox "Cannot handle negative powers yet"
Exit Function
End If
'handle any negative signs
bA = (Left(sA, 1) = "-")
If bA Then sA = Mid(sA, 2) Else sA = Mid(sA, 1)
If bA And RealMod(iExp, 2) <> 0 Then bR = True
'run multiplication loop
IntStrByExp = "1"
Do Until iExp <= 0
DoEvents 'permits break key use
IntStrByExp = Multiply(IntStrByExp, sA)
iExp = iExp - 1
Loop
'remove any leading zeros
Do While Len(IntStrByExp) > 1 And Left(IntStrByExp, 1) = "0"
IntStrByExp = Mid(IntStrByExp, 2)
Loop
'decide on any signs
If IntStrByExp <> "0" And bR Then
IntStrByExp = "-" & IntStrByExp
End If
End Function
See Also
External Links
- Rebecca Gabriella's String Math Module: Big Integer Library for VBA (Visual Basic for Applications).
Excel Sheet True Used Range
Summary
- This code listing is for Excel. The procedure GetUsedRange returns the true used range of the Worksheet in the function name. An example is also given below of its use in the procedure WorkRangeInArray. It can typically be used to find the next writing position on a worksheet, but in any case returns all of the cell limits on each run.
- Reports on various internet sites describe problems with the built-in UsedRange function. The problem types, apart from errors of understanding, seem to be divided between issues concerning the number of cells scrolled and errors in reporting the used range itself. This author has been unable to reproduce errors in reporting the UsedRange but requests inputs from interested parties. Readers with a clear demonstration of the UsedRange problem might care to advise me of it in the Discussion tab of this page. It is true to say that the removal of cell content at the end of a worksheet will not result in a revised scrolled region, and the use of Ctrl-End will still travel to the old position after deletion. These two matters are not necessarily linked however, since this still happens even while the UsedRange is correctly reported. In the meantime this code module will obtain a true used range.
- The procedure GetUsedRange approaches the used cells from the outer limits in all four directions, and then, after noting the first filled cells that it encounters for each direction, defines the overall range as the smallest bounding rectangle that fits the whole thing. It optionally returns the row and column bounds at the same time.
- The procedure WorkRangeInArray makes use of GetUsedRange in an example that loads a source sheet range onto an array for work, then passes it back to a target sheet, same or other, at some specified or default position.
VBA Code Listing (Modified 3 Dec 2016)
Added descriptive variable names for GetUsedRange parameters in accordance with suggestion in Discussion.(3 Dec 2016)
Option Explicit
Sub TestGetUsedRange()
'assumes that there is a block of filled cells on worksheet 1
Dim rng As Range, t, wsS As Worksheet
Dim fr As Long, lr As Long, fc As Long, lc As Long
Set wsS = ThisWorkbook.Worksheets("Sheet1")
Set wsT = ThisWorkbook.Worksheets("Sheet2")
Set rng = GetUsedRange(wsS, fr, fc, lr, lc)
'count the row and cols in range
MsgBox (lr - fr + 1) & " Rows in the range"
MsgBox (lc - fc + 1) & " Columns in the range"
'get first row number and first col number in range
MsgBox fr & " is first row number in the range"
MsgBox fc & " is first col number in the range"
'get last row number and last col number in range
MsgBox lr & " is last row number in the range"
MsgBox lc & " is last col number in the range"
End Sub
Function GetUsedRange(ws As Worksheet, Optional FirstUsedRow As Long, Optional FirstUsedColumn As Long, _
Optional LastUsedRow As Long, Optional LastUsedColumn As Long) As Range
'gets an accurate used range
Dim s As String, X As Long
Dim rng As Range
Dim r1Fixed As Long, c1Fixed As Long
Dim r2Fixed As Long, c2Fixed As Long
Dim r1 As Long, c1 As Long
Dim r2 As Long, c2 As Long
Dim i As Long
Set GetUsedRange = Nothing
'Start with Excel's UsedRange function since
'any such Excel error results in wider limits
Set rng = ws.UsedRange
'get bounding cells for Excel's used range
'that is, cells(r1,c1) to cells(r2,c2)
r1 = rng.Row
r2 = rng.Rows.Count + r1 - 1
c1 = rng.Column
c2 = rng.Columns.Count + c1 - 1
'early exit for single cell or none used
If r1 = r2 And c1 = c2 Then
Set GetUsedRange = ws.Cells(r1, c1)
FirstUsedRow = r1: LastUsedRow = r2: FirstUsedColumn = c1: LastUsedColumn = c2
Exit Function
Else
'continue to find used range
End If
'save existing values
r1Fixed = r1
c1Fixed = c1
r2Fixed = r2
c2Fixed = c2
'check rows from top down for all blanks
'if found shrink rows
For i = 1 To r2Fixed - r1Fixed + 1
If Application.CountA(rng.Rows(i)) = 0 Then
'empty row -- reduce
r1 = r1 + 1
Else
'nonempty row, get out
Exit For
End If
Next
'repeat for columns from left to right
For i = 1 To c2Fixed - c1Fixed + 1
If Application.CountA(rng.Columns(i)) = 0 Then
'empty row -- reduce
c1 = c1 + 1
Else
'nonempty row, get out
Exit For
End If
Next
'reset the range
Set rng = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
'start again
r1Fixed = r1
c1Fixed = c1
r2Fixed = r2
c2Fixed = c2
'do rows from bottom up
For i = r2Fixed - r1Fixed + 1 To 1 Step -1
If Application.CountA(rng.Rows(i)) = 0 Then
r2 = r2 - 1
Else
Exit For
End If
Next
'repeat for columns from right to left
For i = c2Fixed - c1Fixed + 1 To 1 Step -1
If Application.CountA(rng.Columns(i)) = 0 Then
c2 = c2 - 1
Else
Exit For
End If
Next
'set output parameters
Set GetUsedRange = ws.Range(ws.Cells(r1, c1), ws.Cells(r2, c2))
FirstUsedRow = r1: LastUsedRow = r2: FirstUsedColumn = c1: LastUsedColumn = c2
End Function
Sub TestWorkRangeInArray()
'place a block of data in Sheet 1 before run
'transfers data via a work array to Sheet 2
Dim wsS As Worksheet, wsT As Worksheet
Set wsS = ThisWorkbook.Worksheets("Sheet1")
Set wsT = ThisWorkbook.Worksheets("Sheet2")
'used range of sheet 1 to sheet 2,
'to new top left start position r,c = 5,13
WorkRangeInArray wsS, wsT, 5, 13
Set wsS = Nothing
Set wsT = Nothing
End Sub
Function WorkRangeInArray(wsSrc As Worksheet, wsTarg As Worksheet, Optional PosR As Long, _
Optional PosC As Long) As Boolean
'loads target sheet range into a work array
'user should add array work to middle section, or not, if just for transfer
'writes work array onto target worksheet, or same if so specified
'optional target sheet position, defaults to same as source
Dim vArr As Variant, rngSrc As Range, rngTarg As Range
Dim fr As Long, fc As Long, lr As Long, lc As Long
Dim nRowsSrc As Long, nColsSrc As Long, nRowsTarg As Long, nColsTarg As Long
'Load target sheet range onto the work array
'gets true used range and its row/col number limits
Set rngSrc = GetUsedRange(wsSrc, fr, fc, lr, lc)
'load values into array
If rngSrc.Cells.Count = 1 Then
ReDim vArr(1 To 1, 1 To 1)
vArr(1, 1) = rngSrc.Value
Else
vArr = rngSrc
End If
'User can place array working here, if needed
'note that code below expects same array for output
'Write work array to position on the target sheet
'activate target sheet
wsTarg.Activate
'decide sheet position for target data
If PosR > 0 And PosC > 0 Then 'use parameter position values
Set rngTarg = wsTarg.Cells(PosR, PosC)
Else
Set rngTarg = wsTarg.Cells(fr, fc) 'position same as source
End If
'extend target range to fit
Set rngTarg = rngTarg.Resize(UBound(vArr, 1), UBound(vArr, 2))
'transfer array data to target sheet
rngTarg = vArr
'Release object variables
Set rngSrc = Nothing
Set rngTarg = Nothing
Set wsSrc = Nothing
Set wsTarg = Nothing
'Transfers
WorkRangeInArray = True
End Function
Bubble Sort One Dimensional Arrays
Summary
This page deals with the sorting of single dimensioned arrays. These are typically the ones used for placing lists into variants with the Array method. It is more rare to find such a sorting routine in VBA, since most sorting is done in two dimensions.
Bubble Sorting One Dimensional Arrays
- The procedure BubbleSort1DArray() uses the slowest of sorting methods. However, there would seem to be no disadvantage in doing so here, since few lists ever attain great size. There are options for ascending or descending sorts, and for the method of return. If a return array is provided, that will be used, otherwise the input array will be changed by returning in that.
The Code Module
Function BubbleSort1DArray(vIn As Variant, bAscending As Boolean, Optional vRet As Variant) As Boolean
' Sorts the single dimension list array, ascending or descending
' Returns sorted list in vRet if supplied, otherwise in vIn modified
Dim First As Long, Last As Long
Dim i As Long, j As Long, bWasMissing As Boolean
Dim Temp As Variant, vW As Variant
First = LBound(vIn)
Last = UBound(vIn)
ReDim vW(First To Last, 1)
vW = vIn
If bAscending = True Then
For i = First To Last - 1
For j = i + 1 To Last
If vW(i) > vW(j) Then
Temp = vW(j)
vW(j) = vW(i)
vW(i) = Temp
End If
Next j
Next i
Else 'descending sort
For i = First To Last - 1
For j = i + 1 To Last
If vW(i) < vW(j) Then
Temp = vW(j)
vW(j) = vW(i)
vW(i) = Temp
End If
Next j
Next i
End If
'find whether optional vRet was initially missing
bWasMissing = IsMissing(vRet)
'transfers
If bWasMissing Then
vIn = vW 'return in input array
Else
ReDim vRet(First To Last, 1)
vRet = vW 'return with input unchanged
End If
BubbleSort1DArray = True
End Function
Bubble Sort on One Key
Summary
This page is intended for procedures that sort on two dimensions. Further, since some make use of multisort methods, this page is restricted to sorting on a single key. That is, using one column or row as the basis of the sort.
Bubble Sort Arrays in VBA
- The procedure is for sorting a two dimensional array. This is perhaps the most common requirement. The options allow for column or row sorts, choice of sort index, and the choice of ascending or descending sorts. There is again, a choice of returning the sorted work in a different array with the input intact, or if not supplied, returning it with the original changed.
- The bubble sort's speed is suitable for most VBA projects, though faster sorting algorithms are used for more demanding applications. Although not available for Excel, those who are using MS Word might consider calling the SortArray function of WordBasic instead. In Excel the WorksheetFunctions might bear some study as to their sorting usefulness.
The Code Module
Function SortArr2D1Key(ByRef vA As Variant, _
Optional ByVal bIsAscending As Boolean = True, _
Optional ByVal bIsRowSort As Boolean = True, _
Optional ByVal SortIndex As Long = -1, _
Optional ByRef vRet As Variant) As Boolean
'--------------------------------------------------------------------------------
' Procedure : SortArr2D1Key
' Purpose : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
' Options include in-place, with the source changed, or
' returned in vRet, with the source array intact.
' Optional parameters default to: ROW SORT in place, ASCENDING,
' using COLUMN ONE as the key.
'--------------------------------------------------------------------------------
Dim condition1 As Boolean, vR As Variant
Dim i As Long, j As Long, y As Long, t 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 bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
'find whether optional vR was initially missing
bWasMissing = IsMissing(vRet)
'If Not bWasMissing Then Set vRet = Nothing
'check input range of SortIndex
If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
Exit Function
Else:
End If
If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
Exit Function
Else:
End If
'pass to a work variable
vR = vA
'steer input options
If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
ROWSORT:
For i = loR To hiR - 1
For j = loR To hiR - 1
If bIsAscending Then
condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
Else
condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
End If
If condition1 Then
For y = loC To hiC
t = vR(j, y)
vR(j, y) = vR(j + 1, y)
vR(j + 1, y) = t
Next y
End If
Next
Next
GoTo TRANSFERS
COLSORT:
For i = loC To hiC - 1
For j = loC To hiC - 1
If bIsAscending Then
condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
Else
condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
End If
If condition1 Then
For y = loR To hiR
t = vR(y, j)
vR(y, j) = vR(y, j + 1)
vR(y, j + 1) = t
Next y
End If
Next
Next
GoTo TRANSFERS
TRANSFERS:
'decide whether to return in vA or vRet
If Not bWasMissing Then
'vRet was the intended return array
'so return vRet leaving vA intact
vRet = vR
Else:
'vRet is not intended return array
'so reload vA with vR
vA = vR
End If
'set return function value
SortArr2D1Key = True
End Function
Bubble Sort on Multiple Keys
Summary
Array Sort on Three Keys
- This rather long VBA code listing allows bubble sorting of an array on three keys. It is sometimes called an intersort.
- In case it is not clear what that means, suppose there are many names to sort; each with two forenames and a surname. The names records occupy a row each and their parts are in separate columns. The first key might sort the surnames column, but there could be many records called Smith. Then the second key sorts among the first forenames where the surnames were similar. And there might still be a lot of John Smith name records that are the same. The third key sorts the second forename column for those cases where there are records with the same surname and first forename combination.
- A similar function can be found on Excel worksheets in the advanced sort functions. Users unfamiliar with this sort type might well experiment there to better understand the process.
- The function here has options for ascending or descending sorts, row sort or column sort, and the option to return the sorted work in another array or the original. Up to three keys can be specified, though if there are unused keys, say, because only two intersorts are needed, it is assumed that Key1 and Key2 will be used before Key3. In any case, unreasonable settings will result in message box advice.
Function SortArr2D3Keys(vA As Variant, _
Optional Key1 As Long = -1, _
Optional Key2 As Long = -1, _
Optional Key3 As Long = -1, _
Optional ByVal bIsAscending As Boolean = True, _
Optional ByVal bIsRowSort As Boolean = True, _
Optional ByRef vR As Variant) As Boolean
'--------------------------------------------------------------------------------------
' Procedure : SortArr2D3Keys
' Purpose : Bubblesorts a 2D array using 3 keys, up or down, on any column or row.
' For example, sorting using up to three columns;
' Eg; first sorts surnames, then sorts among same surnames for first names,
' then among similar surnames with same first names for middle names.
' Options include in-place, with the source changed, or
' if supplied, returned in vR, with the source array intact.
' Optional parameters default to: ROW SORT, ASCENDING.
' Trailing key options that are not needed should be set to same as previous.
'---------------------------------------------------------------------------------------
ASSIGNMENTS:
Dim condition1 As Boolean, vW As Variant, Temp
Dim i As Long, j As Long, y As Long, t 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
Dim sCombo As String, reply
Dim b1Used As Boolean, b2Used As Boolean, b3Used As Boolean
'find bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
'find whether optional vR was initially missing
bWasMissing = IsMissing(vR)
If Not bWasMissing Then Set vR = Nothing
KEYCHECKS:
If Key1 <> -1 Then
b1Used = True
'check key within bounds
If bIsRowSort And (Key1 < loC Or Key1 > hiC) Then
MsgBox "Sort key1 out of bounds"
Exit Function
End If
If Not bIsRowSort And (Key1 < loR Or Key1 > hiR) Then
MsgBox "Sort key1 out of bounds"
Exit Function
End If
End If
If Key2 <> -1 Then
b2Used = True
'check key within bounds
If bIsRowSort And (Key2 < loC Or Key2 > hiC) Then
MsgBox "Sort key2 out of bounds"
Exit Function
End If
If Not bIsRowSort And (Key2 < loR Or Key2 > hiR) Then
MsgBox "Sort key2 out of bounds"
Exit Function
End If
End If
If Key3 <> -1 Then
b3Used = True
'check key within bounds
If bIsRowSort And (Key3 < loC Or Key3 > hiC) Then
MsgBox "Sort key3 out of bounds"
Exit Function
End If
If Not bIsRowSort And (Key3 < loR Or Key3 > hiR) Then
MsgBox "Sort key3 out of bounds"
Exit Function
End If
End If
sCombo = CStr(Abs(b1Used)) & CStr(Abs(b2Used)) & CStr(Abs(b3Used))
'MsgBox sCombo
Select Case sCombo
Case "000"
'no keys selected
If bIsRowSort Then
reply = MsgBox("No keys selected." & vbCrLf & _
"Use lower bound column for a single key?", vbCritical + vbQuestion + vbYesNo, "Please confirm your selection...")
Select Case reply
Case vbYes
Key1 = loC
Case Else
Exit Function
End Select
Else
reply = MsgBox("No keys selected." & vbCrLf & _
"Use lower bound row for a single key?", vbCritical + vbQuestion + vbYesNo, "Please confirm your selection...")
Select Case reply
Case vbYes
Key1 = loR
Case Else
Exit Function
End Select
End If
Case "100", "110", "111"
'proceed normally
Case Else
MsgBox "Only three combinations of sort keys are possible" & vbCrLf & _
"Key1 alone, Key1 with Key2, or Key1 with Key2 and Key3."
Exit Function
End Select
WORKARRAY:
'use a working array for sorting
vW = vA
STEERING:
'steer input options
If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
ROWSORT:
'row sort using 3 intersort keys
'Sort rows of array using first column index, Key1
For i = loR To hiR - 1
For j = i + 1 To hiR
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(i, Key1) > vW(j, Key1)
Else
condition1 = vW(i, Key1) < vW(j, Key1)
End If
If condition1 Then
For c = loC To hiC
Temp = vW(i, c)
vW(i, c) = vW(j, c)
vW(j, c) = Temp
Next
End If
Next
Next
If b2Used Then
'Sort rows of array using second column index, Key2
For i = loR To hiR - 1
For j = i + 1 To hiR
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(i, Key1) = vW(j, Key1) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(i, Key2) > vW(j, Key2)
Else
condition1 = vW(i, Key2) < vW(j, Key2)
End If
If condition1 Then
For c = loC To hiC
Temp = vW(i, c)
vW(i, c) = vW(j, c)
vW(j, c) = Temp
Next
End If
End If
Next
Next
Else
GoTo TRANSFERS
End If
If b3Used Then
'Sort rows of array using third column index, Key3
For i = loR To hiR - 1
For j = i + 1 To hiR
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(i, Key1) = vW(j, Key1) And vW(i, Key2) = vW(j, Key2) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(i, Key3) > vW(j, Key3)
Else
condition1 = vW(i, Key3) < vW(j, Key3)
End If
If condition1 Then
For c = loC To hiC
Temp = vW(i, c)
vW(i, c) = vW(j, c)
vW(j, c) = Temp
Next
End If
End If
Next
Next
End If
GoTo TRANSFERS
COLSORT:
'column sort using 3 intersort keys
'Sort columns of array using first row index, Key1
For i = loC To hiC - 1
For j = i + 1 To hiC
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(Key1, i) > vW(Key1, j)
Else
condition1 = vW(Key1, i) < vW(Key1, j)
End If
If condition1 Then
For c = loR To hiR
Temp = vW(c, i)
vW(c, i) = vW(c, j)
vW(c, j) = Temp
Next
End If
Next
Next
If b2Used Then
'Sort columns of array using second row index, Key2
For i = loC To hiC - 1
For j = i + 1 To hiC
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(Key1, i) = vW(Key1, j) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(Key2, i) > vW(Key2, j)
Else
condition1 = vW(Key2, i) < vW(Key2, j)
End If
If condition1 Then
For c = loR To hiR
Temp = vW(c, i)
vW(c, i) = vW(c, j)
vW(c, j) = Temp
Next
End If
End If
Next
Next
Else
GoTo TRANSFERS
End If
If b3Used Then
'Sort columns of array using third row index, Key2
For i = loC To hiC - 1
For j = i + 1 To hiC
'if-condition avoids independence of second sort
'note that a third stage would have THREE terms
If vW(Key1, i) = vW(Key1, j) And vW(Key2, i) = vW(Key2, j) Then
'set < for descending, and > for ascending
If bIsAscending Then
condition1 = vW(Key3, i) > vW(Key3, j)
Else
condition1 = vW(Key3, i) < vW(Key3, j)
End If
If condition1 Then
For c = loR To hiR
Temp = vW(c, i)
vW(c, i) = vW(c, j)
vW(c, j) = Temp
Next
End If
End If
Next
Next
End If
GoTo TRANSFERS
TRANSFERS:
'decide whether to return in vA or vR
If Not bWasMissing Then
'vR was the intended return array
'so return vR leaving vA intact
vR = vW
Else:
'vR is not intended
'so reload vA with vR
vA = vW
End If
'set return function value
SortArr2D3Keys = True
End Function
Variable Beep from VBA
Summary
This VBA code module examines various uses of the Beep() API. Its parameters are frequency and duration. It has no wait parameter, so chords are not possible, just simple tones. It is stated to work well for Windows 7 versions onwards, but might ignore the parameters for earlier versions. Simple musical scales and tunes are illustrated, in addition to a Morse code text sender.
Beep API Bugs
In the past many problems were found in the use of the Beep API. Since Windows 7, the Beep API has been re-coded by Microsoft to work with computer sound cards. Prior to Windows 7, the API functioned only with an on-board sound chip. Unfortunately, during the transition from sound chips to sound cards, some computer manufacturers still used chips while others used cards. This is the basis of the problem for older Windows versions. No problems should be encountered in the use of the Beep API for recent builds.
Procedure Notes
Several procedures are provided in the module. Copy the entire code into a standard module for testing. The procedures are as follows:
- Beeper() is the basic form of the function. Running it will make a simple tone in the computer's speakers. Note that it does not refer to the alert sounder that is built into Windows, but the speakers used for listening to media. Both the frequency and duration of the sound can be adjusted, though the consistency of the output, being designed for selected frequency use is not very good.
- TestNotes() expands on the basic format. Run this to produce up and down scales. There are two ways to access frequencies:
- The first is just to enter the exact frequencies for each note in a sequence of code lines; this is the case for the do re me scales, the so-called natural notes, eg, C,D,E,F,G,A,B,C....
- The other, when the exact frequencies are not known is to use a formula to calculate the frequency based on knowledge of the relative position of the note with respect to a reference point. (See Figures 1 and 2). The reference point in this case is note A = 440 Hz. Figure 1 shows three octaves of notes around 440Hz, and Figure 2 shows how notes in a simple music score relate to note distance. The note-distance value can be used to calculate frequency for any other note. For example, in Figure 2, notice that the G notes have a distance of 10; this and all other note distances are listed in the table of Figure 1. When it is understood that G notes always occupy the second line of the treble clef, a simple score can be marked with both notes and distances, ready for coding.
- SendMorse() sounds out the Morse code for a parameter string. The procedure gives a basic output, with adjustable frequency (Hz) and dot length (milliseconds).
- Delays are introduced with Delay() for the inter-element (one dot), inter-character (3 dots), and inter-word (7 dots) intervals, in addition to the basic one to three ratio for dots and dashes. All timing is derived from the length of one short dot element. A random element can be added to all timing in Random(), where the maximum percentage of error can be set; this is said to better resemble a human hand rather that the too-perfect program.
- The convention is to estimate words per minute in terms of dot duration also, as T = 1200 / W where T is dot duration in milliseconds and W is the generated number of words per minute. The international Morse code is given for reference in Figure 3.
The Code
- Modified 24 Dec 18 to add randomness to all timing in SendMorse()
- Modified 24 Dec 18 to add an omitted sCode declaration in SendMorse()
- Modified 23 Dec 18 to correct data in SendMorse() array vSN
- Modified 22 Dec 18 to show use of note distance in a tune.
- Modified 21 Dec 18 to correct timing errors for Morse code procedures.
Run TestBeeper(), TestNotes(), or testSendMorse() to run the various procedures.
Option Explicit
Public Declare PtrSafe Function BeepAPI Lib "kernel32" Alias "Beep" _
(ByVal Frequency As Long, ByVal Milliseconds As Long) As Long
Sub TestBeeper()
'run this to test beeper
Dim nFreq As Long, nDur As Long
nFreq = 800 'frequency (Hertz)
nDur = 500 'duration (milliseconds)
'call beeper function
Beeper nFreq, nDur
End Sub
Function Beeper(nF As Long, nD As Long) As Boolean
'makes a beep sound of selected frequency and duration
'This works for NT/2000/XP and beyond.
'Before that, frequency and duration ignored.
BeepAPI nF, nD
Beeper = True
End Function
Sub TestNotes()
'music notes played using known frequencies and those
'calculated from knowlege of their relative positions'
Dim vAN As Variant, vOTJ As Variant, vOTJD As Variant
Dim i As Long, nFreq As Long
Dim nDur As Long, nLen As Long
'sets the basic note duration
nDur = 500
'store the specific frequencies in array - zero based...
'these frequencies are for do,re,me,fa,so,la,te,do based on middle C =261.63Hz (262)
'CDEFGABC
vAN = Array(262, 294, 330, 349, 392, 440, 494, 523)
'or store a jingle in note difference notation. Ode To Joy on beeper.
vOTJ = Array(7, 7, 8, 10, 10, 8, 7, 5, 3, 3, 5, 7, 7, 5, 5) 'note positions from 440Hz
vOTJD = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2) 'durations
'scales up
'CDEFGABC
'do re me fa so la te do
For i = 0 To 7
nFreq = vAN(i)
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'scales down
'CBAGFEDC
'do te la so fa me re do
For i = 7 To 0 Step -1
nFreq = vAN(i)
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'34 notes, naturals, sharps and flats
'played using note position from 440Hz
For i = -5 To 28
nFreq = CInt(440 * 2 ^ (i / 12))
BeepAPI nFreq, nDur
Next i
Delay 1000 'delay one second
'Ode to Joy - albeit crude, using note distance only
For i = 0 To 14
nFreq = CInt(440 * 2 ^ (vOTJ(i) / 12))
BeepAPI nFreq, 400 * vOTJD(i)
Next i
Delay 1000 'delay one second
'or use direct entries to make a custom sound
BeepAPI 262 * 2, 200
BeepAPI 494 * 2, 200
BeepAPI 494 * 2, 200
BeepAPI 262 * 2, 500
End Sub
Sub testSendMorse()
'run this to test the Morse code sender
'integers and simple alphabet only
Dim sIn As String
Dim start As Single, ends As Single
sIn = "The quick brown fox jumps over the lazy dog 0123456789 times"
'start = Timer
SendMorse sIn, 440, 120 'string,freq (Hz),dot length (mS)
'ends = Timer - start
'MsgBox ends
End Sub
Sub SendMorse(ByVal sIn As String, nUF As Single, nUL As Single)
'Sounds out Morse code for input string sIn
'Parmeters frequency(Hz) and dot length(mS)
Dim vSL As Variant, vSN As Variant, vM As Variant
Dim i As Long, j As Long, nAsc As Integer
Dim sWord As String, sCode As String
'check that there is a decent string input
If Trim(sIn) = "" Then
MsgBox "Illegal characters in input string - closing"
Exit Sub
End If
'load letter array with morse code- 1 for dot and 3 for dah
vSL = Array("13", "3111", "3131", "311", "1", "1131", "331", "1111", "11", _
"1333", "313", "1311", "33", "31", "333", "1331", "3313", "131", _
"111", "3", "113", "1113", "133", "3113", "3133", "3311") 'a,b,c,...z
'load number array with morse code- 1 for dot and 3 for dah
vSN = Array("33333", "13333", "11333", "11133", "11113", _
"11111", "31111", "33111", "33311", "33331") '0,1,2,...9
'split the input string into words
vM = Split(Trim(sIn), " ") 'zero based
For i = LBound(vM) To UBound(vM) 'step through words
'get one word at a time
sWord = LCase(vM(i)) 'current word
'get one chara at a time
For j = 1 To Len(sWord)
'look up chara asci code
nAsc = Asc(Mid(sWord, j, 1))
'get morse sequence from array
Select Case nAsc
Case 97 To 122 'a letter
sCode = vSL(nAsc - 97)
MakeBeeps sCode, nUL, nUF
If j <> Len(sWord) Then
Delay (nUL * 3) 'add 3 spaces between letters
End If
Case 48 To 57 'an integer
sCode = vSN(nAsc - 48)
MakeBeeps sCode, nUL, nUF
If j <> Len(sWord) Then
Delay (nUL * 3) 'add 3 spaces between letters
End If
Case Else
MsgBox "Illegal character in input" & vbCrLf & _
"Only A-Z and 0-9 permitted."
End Select
Next j
If i <> UBound(vM) Then Delay (nUL * 7) 'add 7 spaces between words
Next i
End Sub
Function MakeBeeps(ByVal sIn As String, ByVal nUL As Single, ByVal nUF As Single) As Boolean
'makes beep sounds for one character based on coded input string
Dim i As Long, j As Long, nLen As Long
Dim nT As Single, nE As Single
For i = 1 To Len(sIn)
'get character element
nLen = CInt(Mid(sIn, i, 1))
Select Case nLen
Case 1
BeepAPI nUF, nUL + Random(nUL)
If i <> Len(sIn) Then Delay nUL
Case 3
BeepAPI nUF, (3 * nUL) + Random(3 * nUL)
If i <> Len(sIn) Then Delay nUL
Case Else
MsgBox "error"
End Select
Next i
MakeBeeps = True
End Function
Function Random(nDot As Single) As Single
'adds a random variation to the timing
'used to better hide machine code signature
'nRand = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Dim nRand As Long, nPercent As Single
Dim nU As Long, nL As Long
'set a number here for max error percentage
'eg; 10 for ten percent error, 0 for none.
nPercent = 10 'max percent plus and minus
'initialize the random generator
Randomize
'generate small random number as the timing error
nRand = Int((nDot * nPercent / 100 + nDot * nPercent / 100 + 1) * Rnd - nDot * nPercent / 100)
Random = nRand
End Function
Sub Delay(nD As Single)
'delays for nD milliseconds
'randomness set in Random()
Dim start As Single
nD = nD + Random(nD) 'add randomness to intention
start = Timer ' Set start time.
Do While Timer < start + nD / 1000
DoEvents ' Yield to other processes.
Loop
End Sub
See Also
Play a WAV File from VBA
Summary
- This code module plays sounds in Excel VBA using existing .wav files. Many such files can be found in the C:\Windows\Media folder, and can be made from text with a suitable VBA procedure.
- The procedure used is an API. This API code has been tested for Win10 64 bit with Excel 2019 64 bit, and works well.
Notes on the Code
- The most general version that applies to all VBA uses an API function sndPlaySound. The code plays audio (WAV) files via the user's speakers as opposed to any internal sounders. Files must already exist on the user's PC for any sound that is played. In Excel, and when the user just needs to play strings, then the built-in Speak function is more convenient.
- Notice that sndPlaySound makes use of a wait parameter. When assembling discrete sounds that are not intended to overlap, the function can be made to play its sound before allowing the next line of code to run. Conversely, to overlap a new note with the tail of an old note, as in the playing of piano keys, the next code line is allowed to run before the sound has completed. Setting the Wait parameter to False will cause the code to run on before completion.
- Libraries of wav sound files can be downloaded from internet pages. They are generally organized for download in zipped files by category. That is to say, a set of spoken numbers, spoken letters, piano keys etc. If the ideal set is not available then there are several free text to wav file applications on the internet that can be downloaded and that allow sound files to be made from typed text, Readers might care to comment in the My discussion page about high quality file sets.
- Quite complex constructions can be made by playing sound files in sequence. Possible applications include audio advice for the progress of long procedure runs, or sound punctuation of the type already used by Microsoft for the opening and closing of processes. Some individuals construct entire piano keyboards on user forms, complete with flats and sharps.
- Readers who intend to use integers or letters for playback as a sequence might be interested to know:
- The task of code writing is greatly simplified if the sound files' names start with the characters that they represent. For example, a file that expresses the sound for one is best called 1.wav, three as 3.wav, and similarly with the letter set. The reason is that a string character from code can be used to construct the name of the file to call. This allows single line calls in loops at times, compared to the accessing of lists of elaborately named files. See the procedure ReadIntegers for the method to use. Clearly, without the wav file set that goes with it, this procedure is of limited use to the reader.
- The lead in and lead out times of sound files can make for a fairly halting delivery. To get around this, record a sound file with as much in the one file as possible, rather than depending on a sum of many to obtain the result.
VBA Code
Option Explicit
'Declaration for Win10 and Office 64 bit
Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Sub TestPlayWavFileAPI()
'run this to play a sound wave (.wav) file
Dim sPath As String
'path to wave file - replace with your own
sPath = "C:\Windows\Media\Ring08.wav"
'test the no-wait feature
PlayWavFileAPI sPath, False
MsgBox "This message box appears during the sound"
'test the wait feature
PlayWavFileAPI sPath, True
MsgBox "This message appears only after the sound stops"
End Sub
Function PlayWavFileAPI(sPath As String, Wait As Boolean) As Boolean
'API declaration of sndPlaySound is modified for 64 bit windows
'and tests well in Excel 2019 vba version 7.1.
'For earlier versions it might be necessary to remove the word PtrSafe
'from the declaration, or to consider another format.
'make sure file exists
If Dir(sPath) = "" Then
Exit Function
End If
If Wait Then
'hold up follow-on code until sound complete
sndPlaySound sPath, 0
Else
'continue with code run while sound is playing
sndPlaySound sPath, 1
End If
End Function
See Also
External Links
- Pearson - Play Sounds: A page by Chip Pearson with much more detail. (Currently still has the now outdated 32 bit code)
- WavePad Download : A FREE sound file editor, that also makes sound files.
- SoundTap Stream Recorder : A FREE stream recorder for anything on the speakers. Part of WavePad suite.
- Switch File Converter : A FREE file type converter. Part of WavePad suite.
- ReadPlease Text Reader : A FREE good quality text reader. Now discontinued, so get a copy while you can.
Make a WAV File from a VBA String
Summary
- This code module will make a voiced wav file starting from a VBA string. A reference should be set in the VBA editor to Microsoft Speech Object Library.
- The parameters are just the intended string to be spoken and a full path to the intended file name. The process MAKES a file but does not speak it as audio. Once made, the wav file can be spoken with procedures in an adjacent page, or tested in Windows Explorer by simply opening it.
- No error code has been added. For example, if an attempt is made to use a folder with restrictions, an error will be raised. Users might consider adding some error trapping.
- The intended target wave file need not exist. If it does not exist it will be made. If it exists however, it will be overwritten.
- Notice that the user should enter his own profile in the file path. This author could not make the environmental paths work which would otherwise have made the code independent of the profile details.
VBA Code
Copy the entire code listing into an Excel standard module. Modify the paths to your own, and run the top procedure to make a reusable wav file of the string. Remember to set a reference to Microsoft Speech Object Library.
Option Explicit
Sub TestStringToWavFile()
'run this to make a wav file from a text input
Dim sP As String, sFN As String, sStr As String, sFP As String
'set parameter values - insert your own profile name first
'paths
sP = "C:\Users\Your Profile Name\Documents\" 'for example
sFN = "Mytest.wav" 'overwrites if file name same
sFP = sP & sFN
'string to use for the recording
sStr = "This is a short test string to be spoken in a user's wave file."
'make voice wav file from string
StringToWavFile sStr, sFP
End Sub
Function StringToWavFile(sIn As String, sPath As String) As Boolean
'makes a spoken wav file from parameter text string
'sPath parameter needs full path and file name to new wav file
'If wave file does not initially exist it will be made
'If wave file does initially exist it will be overwritten
'Needs reference set to Microsoft Speech Object Library
Dim fs As New SpFileStream
Dim Voice As New SpVoice
'set the audio format
fs.Format.Type = SAFT22kHz16BitMono
'create wav file for writing without events
fs.Open sPath, SSFMCreateForWrite, False
'Set wav file stream as output for Voice object
Set Voice.AudioOutputStream = fs
'send output to default wav file "SimpTTS.wav" and wait till done
Voice.Speak sIn, SVSFDefault
'Close file
fs.Close
'wait
Voice.WaitUntilDone (6000)
'release object variables
Set fs = Nothing
Set Voice.AudioOutputStream = Nothing
'transfers
StringToWavFile = True
End Function
See Also
External Links
- Pearson - Play Sounds: A page by Chip Pearson with much more detail.
- WavePad Download : A FREE sound file editor, that also makes sound files.
- SoundTap Stream Recorder : A FREE stream recorder for anything on the speakers. Part of WavePad suite.
- Switch File Converter : A FREE file type converter. Part of WavePad suite.
- ReadPlease Text Reader : A FREE good quality text reader. Now discontinued, so get a copy while you can.
Read Aloud Strings and Text
Summary
This page contains Excel VBA code to read out the contents of strings; that is, text held in a string variable. It can be adapted for use elsewhere in MS Office.
Code Notes
Place the entire code listing into a Standard Module and save the file with an xlsm suffix. Run the various subs to see how the code works.
The VBA Code
Sub BasicExcelSpeech()
'Speaks the supplied string text in a default Excel voice
'Default voice is changed via Windows Control Panel
'Named Parameters of Speak():
'Text: the text to read (Required)
'SpeakAsync:=0, waits until done, or with 1, code runs during play (Optional)
'SpeakXML:=0 , normal setting, or with 1, to ignore xml tags (Optional)
'Purge:=0 , normal play, or with 1, clears the present play (Optional)
Application.Speech.Speak Text:="Hello", SpeakAsync:=0, SpeakXML:=0, Purge:=0
End Sub
Sub testSpeakEachDigit()
SpeakEachDigit "0123456789"
End Sub
Function SpeakEachDigit(sIn As String) As Boolean
'non API method
'uses excel's speak function to read a string, chara by chara
'one character at a time
Dim n As Long, m As Long, sS As String
Application.EnableSound = True
For n = 1 To Len(sIn)
DoEvents
sS = Mid(sIn, n, 1) 'take one character
Application.Speech.Speak sS, 0, 0, 0
Next n
SpeakEachDigit = True
End Function
Sub testSetupSpeechVoice()
'Run this to test SetupSpeechVoice()
Dim sTxt As String, nVoc As Integer, nSpd As Integer, nVol As Integer
sTxt = "The quick brown fox jumps over the lazy dog 1234567890 times."
nVoc = 1 'chosen voice 0 or 1
nSpd = 0 'speed of reading -10 to +10
nVol = 100 'volume level 0 to 100
SetupSpeechVoice sTxt, nVoc, nSpd, nVol
End Sub
Function SetupSpeechVoice(sText As String, Optional ByVal nVoices As Integer, _
Optional ByVal nRate As Integer, _
Optional ByVal nLoudness As Integer) As Boolean
'Selects voice using an index, rate of speech -10 to +10,
'and volume 0-100 for Speech.Speak()
'Needs a VBA editor reference to Microsoft Speech Object Library
Dim voc As SpeechLib.SpVoice
Set voc = New SpVoice
'avoid wrong choice of voice
If nVoices > voc.GetVoices.Count - 1 Or nVoices < 0 Then
MsgBox "Voice integer is out of range"
Exit Function
End If
With voc
Set .Voice = .GetVoices.Item(nVoices)
.Rate = nRate
.Volume = nLoudness
.Speak sText
End With
SetupSpeechVoice = True
End Function
Sub ListAvailableVoices()
'run this to know the id of the available voices
'Needs a VBA editor reference to Microsoft Speech Object Library
Dim n As Integer, sAccum As String
Dim voc As SpeechLib.SpVoice
Set voc = New SpVoice
For n = 0 To voc.GetVoices.Count - 1
Set voc.Voice = voc.GetVoices.Item(n)
sAccum = sAccum & " " & n & " - " & voc.Voice.GetDescription & vbCrLf
voc.Speak "My voice index number is " & CStr(n)
Next n
MsgBox sAccum
End Sub
Get Array Data Stats
Summary
This VBA code module is intended for MS Excel, since it prints a basic set of statistics onto the worksheet. It assumes that there is well behaved numerical data in a 1D array as an input. A frequency distribution is produced and associated statistics for the set.
Notes on the code
- Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.
VBA Code MOdule
Option Explicit
Option Base 1 'important
Private Sub testMakeBinsAndStatsFromArray()
'Run this to test making of frequency
'distribution and stats from arrays
'THIS SUB CLEARS AND WRITES TO SHEET1
Dim vArr As Variant, vBins As Variant
'load a typical 1D data array
vArr = Array(0, 0.125, 1, 5, 5, 23, 5.1, 5, 10, 10.05, 15, 15.01, 7.3, 16, 15, 0, 3)
'load a typical 1D interval array
'numbers are upper-limit-inclusive,
'from previous-limit-exclusive
vBins = Array(5, 10, 15, 20)
BinStatsOfArrayData vArr, vBins, "Test"
'report end
MsgBox "Display done."
End Sub
Private Sub BinStatsOfArrayData(vI As Variant, vB As Variant, Optional sLabel As String = "")
'Gets the basic stats for a 1D array of numbers.
'Bin width is provided by an array in vB.
'Results to the worksheet. Displays frequency
'distribution, average, median, mode, minimum,
'maximum, standard deviation, and variance.
'THIS SUB CLEARS AND WRITES TO SHEET1
Dim vR As Variant, vD As Variant
Dim n As Long, bOK As Boolean
Dim LB As Long, UB As Long, LBI As Long, UBI As Long
LBI = LBound(vI, 1): UBI = UBound(vI, 1)
bOK = FreqDist(vI, vB, vR)
LB = LBound(vR, 1): UB = UBound(vR, 1)
ReDim vD(LB To UB + 12, 1 To 3)
If bOK Then 'load a display array
'set labels and headings
vD(1, 1) = sLabel: vD(1, 2) = "Value": vD(1, 3) = "Quantity"
'frequency distribution display
For n = LB To UB
If n = LB Then 'first bin
vD(n + 2, 2) = "<=" & vB(n) 'bin size
vD(n + 2, 3) = vR(n, 1) 'quantity
ElseIf n > LB And n < UB Then 'middle bins
vD(n + 2, 2) = ">" & vB(n - 1) & " and <=" & vB(n) 'bin size
vD(n + 2, 3) = vR(n, 1) 'quantity
ElseIf n = UB Then 'last bin
vD(n + 2, 2) = ">" & vB(n - 1) 'bin size
vD(n + 2, 3) = vR(n, 1) 'quantity
End If
vD(n + 2, 1) = "Bin # " & n 'headings
Next n
'get various other stats estimates for display
On Error Resume Next 'avoids Mode() error when no value stands out
With Application.WorksheetFunction
vD(UB + 4, 1) = "Average": vD(UB + 4, 3) = Format(.Average(vI), "#0.000")
vD(UB + 5, 1) = "Median": vD(UB + 5, 3) = .Median(vI)
vD(UB + 6, 1) = "Mode": vD(UB + 6, 3) = .Mode(vI)
vD(UB + 7, 1) = "Minimum": vD(UB + 7, 3) = .Min(vI)
vD(UB + 8, 1) = "Maximum": vD(UB + 8, 3) = .Max(vI)
vD(UB + 9, 1) = "Std.Deviation": vD(UB + 9, 3) = Format(.StDevP(vI), "#0.000")
vD(UB + 10, 1) = "SD/Average % (CV)": vD(UB + 10, 3) = Format(.StDevP(vI) * 100 / .Average(vI), "#0.000")
vD(UB + 11, 1) = "Variance": vD(UB + 11, 3) = Format(.VarP(vI), "#0.000")
vD(UB + 12, 1) = "No. of Samples": vD(UB + 12, 3) = UBound(vI) - LBound(vI) + 1
End With
Err.Clear
Else
MsgBox "Problems getting bin count - closing"
Exit Sub
End If
'output to sheet
ClearWorksheet "Sheet1", 3 'clear both contents and formats of the worksheet
Array2DToSheet vD, "Sheet1", 3, 3 'transfer whole array to sheet with top left at row3, col3
FormatCells "Sheet1" 'apply font and autofit formats to all cells of the worksheet
End Sub
Private Function FreqDist(vData As Variant, vBounds As Variant, vRet As Variant) As Boolean
'Gets the frequency distribution for data values in vData
'Returns in vRet based on bin range data in vBounds.
Dim vFD As Variant
Dim LBD As Long, UBD As Long, LBB As Long, UBB As Long
'get work array bounds
LBD = LBound(vData): UBD = UBound(vData) '1D
LBB = LBound(vBounds): UBB = UBound(vBounds) '1D
ReDim vRet(LBB To UBB + 1) 'one more than bounds
With Application.WorksheetFunction
'always returns as one-based array!
vRet = .Frequency(vData, vBounds)
End With
FreqDist = True
End Function
Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
'clears worksheet contents, formats, or both
'but does not remove charts from the worksheet
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Sub
End Select
End With
oWSht.Cells(1, 1).Select
End Sub
Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'modify end point for parameter starting values
nNewEndR = nRows + nStartRow - 1
nNewEndC = nCols + nStartCol - 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = vIn
End Sub
Private Sub FormatCells(sSht As String)
' Applies certain formats to all cells
' of the named parameter worksheet
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
oSht.Activate
'format all cells of the worksheet
oSht.Cells.Select
With Selection
.Font.Name = "Consolas" 'mono
.Font.Size = 20
.Columns.AutoFit
.Rows.AutoFit
.HorizontalAlignment = xlLeft 'xlRight 'xlCenter
.VerticalAlignment = xlBottom 'xlCenter 'xlTop
End With
oSht.Range("A1").Select
End Sub
See Also
Discrete Data Bin Stats
Summary
This code module is intended for MS Excel, since it writes a set of statistics to the worksheet. It assumes that there is discrete data in a 1D array, either string or numeric. A set of statistics is printed, not for the raw data on the array, but for the bin-count of discrete values found on it. It includes a listing of the bin counts and other statistics. For example, if the array contained only elements with a one or a zero value, the results would list the overall counts of each, and produce other statistics.
Notes on the code
- Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.
VBA Code Module
Option Explicit
Option Base 1
Private Sub testCountUniqueArrayValues()
'Run this to count unique values,
'string or numeric, in an array.
'THIS SUB CLEARS AND WRITES TO SHEET1
Dim vArr As Variant, nT As Long
'load a typical 1D data array with test data
vArr = Array("and", "AND", "And", 7, "C", 5, 8, 3, 5, 6, 7.6, "D", "B", "A", "C", "D")
'pass array to the proc with label for the display
CountUniqueArrayValues vArr, 2, 2, "Test Set 1:"
'report end
MsgBox "Display done."
End Sub
Private Sub CountUniqueArrayValues(vI As Variant, Optional nRow As Long = 1, _
Optional nCol As Long = 1, Optional sLabel As String = "")
'Counts instances of unique values in vI. Generates various stats
'for the bin quantities of each, rather than the array of values themselves.
'THIS SUB CLEARS AND WRITES TO SHEET1
Dim vRV As Variant, vRQ As Variant, vDS As Variant
Dim LB As Long, UB As Long, vDB As Variant
Dim n As Long, bOK As Boolean
'make bins and count contents
bOK = DiscreteItemsCount(vI, vRV, vRQ)
LB = LBound(vRV, 1): UB = UBound(vRV, 1)
ReDim vDS(1 To 12, 1 To 3)
ReDim vDB(LB To UB + 2, 1 To 3)
If bOK Then 'load bins and stats arrays
vDB(1, 1) = sLabel: vDB(1, 2) = "Value": vDB(1, 3) = "Quantity"
For n = LB To UB
vDB(n + 2, 1) = "Bin # " & n 'headings
vDB(n + 2, 2) = vRV(n) 'value
vDB(n + 2, 3) = vRQ(n) 'quantity
Next n
On Error Resume Next 'avoids Mode() error when no value stands out
With Application.WorksheetFunction
vDS(1, 1) = sLabel: vDS(1, 2) = "": vDS(1, 3) = "Quantity"
vDS(3, 1) = "Average": vDS(3, 3) = Format(.Average(vRQ), "#0.000")
vDS(4, 1) = "Median": vDS(4, 3) = .Median(vRQ)
vDS(5, 1) = "Mode": vDS(5, 3) = .Mode(vRQ)
vDS(6, 1) = "Minimum": vDS(6, 3) = .Min(vRQ)
vDS(7, 1) = "Maximum": vDS(7, 3) = .Max(vRQ)
vDS(8, 1) = "Std.Deviation": vDS(8, 3) = Format(.StDevP(vRQ), "#0.000")
vDS(9, 1) = "StDev/Av %": vDS(9, 3) = Format(.StDevP(vRQ) * 100 / .Average(vRQ), "#0.000")
vDS(10, 1) = "Variance": vDS(10, 3) = Format(.VarP(vRQ), "#0.000")
vDS(11, 1) = "No.Unique Values": vDS(11, 3) = UBound(vRQ) - LBound(vRQ) + 1
vDS(12, 1) = "No.Samples": vDS(12, 3) = UBound(vI) - LBound(vI) + 1
End With
Err.Clear
Else
MsgBox "Problems getting bin count - closing"
Exit Sub
End If
'output to sheet
ClearWorksheet "Sheet1", 3 'clear both contents and formats of the worksheet
Array2DToSheet vDS, "Sheet1", nRow, nCol 'transfer stats panel to sheet with top left at row3, col3
If UB <= 65536 Then 'rows limit for excel 2003
Array2DToSheet vDB, "Sheet1", nRow + 13, nCol 'transfer bins panel to sheet with top left below stats
Else
MsgBox "To many bins for sheet -closing"
Exit Sub
End If
FormatCells "Sheet1" 'apply font and autofit formats to all cells of the worksheet
End Sub
Private Function DiscreteItemsCount(vIn As Variant, vRetV As Variant, vRetQ As Variant) As Boolean
'Counts number of repeats of element values found in vIn
'Returns with one column for each unitque value and quantity found.
'Returns as 2D vRet, unsorted; row1=input value, row2=item count.
Dim vA As Variant, vTS As Variant, vTB As Variant
Dim s As Long, b As Long, n As Long, bFound As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
Dim LBS As Long, UBS As Long
'dimension 2D work array
ReDim vA(1 To 2, 1 To 1)
'get source 1D array bounds
LBS = LBound(vIn): UBS = UBound(vIn)
'get work array bounds
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
'intitial values
s = LBS
b = 0
vA(2, 1) = 0
Do 'step through store
DoEvents
'get source element value
vTS = vIn(s)
'check bins
Do
DoEvents
b = b + 1
'get bin element value
vTB = vA(1, b)
If vTS = vTB Then 'found in bins
vA(2, b) = CLng(vA(2, b)) + 1 'update bin
bFound = True
End If
Loop Until b >= UB2 Or bFound = True
If bFound = False Then 'no such bin exists yet
'not found in bins
If vA(2, UB2) <> 0 Then 'first element been used
ReDim Preserve vA(LB1 To UB1, LB2 To UB2 + 1)
UB2 = UBound(vA, 2)
End If
'update new bin
vA(1, UB2) = vTS
vA(2, UB2) = 1
bFound = True
End If
'reset loop variables
bFound = False
b = 0
s = s + 1
Loop Until s > UBS
'transfers -need to be separate for other uses
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
ReDim vRetV(LB2 To UB2) 'contains values
ReDim vRetQ(LB2 To UB2) 'contains quantities
For n = LB2 To UB2
vRetV(n) = vA(1, n)
vRetQ(n) = vA(2, n)
Next n
For n = LB2 To UB2
Debug.Print vRetV(n) & vbTab & vRetQ(n)
Next n
Debug.Print vbCrLf
DiscreteItemsCount = True
End Function
Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
'clears worksheet contents, formats, or both
'but does not remove charts from the worksheet
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Sub
End Select
End With
oWSht.Cells(1, 1).Select
End Sub
Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'modify end point for parameter starting values
nNewEndR = nRows + nStartRow - 1
nNewEndC = nCols + nStartCol - 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = vIn
End Sub
Private Sub FormatCells(sSht As String)
' Applies certain formats to all cells
' of the named parameter worksheet
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
oSht.Activate
'format all cells of the worksheet
oSht.Cells.Select
With Selection
.Font.Name = "Consolas" 'mono
.Font.Size = 20
.Columns.AutoFit
.Rows.AutoFit
.HorizontalAlignment = xlLeft 'xlRight 'xlCenter
.VerticalAlignment = xlBottom 'xlCenter 'xlTop
End With
oSht.Range("A1").Select
End Sub
See Also
The Knuth String Shuffle
Summary
- This code module includes both a Fisher-Yates character shuffling routine for strings, and a Durstenfeld-Knuth routine to shuffle one-dimensional arrays.
- The procedure FisherYatesStrShuffle() shuffles characters of a single string. This is limited to shifting single characters around within one string.
- Procedure KnuthArrShuffle() sorts the elements of a one-dimensional array. The procedure is limited only by what can be stored in array elements.
- The two methods are pseudo-random and bias-free. Elsewhere, the use of a random generator does not necessarily guarantee that the results will be free from bias.
- The code can work in any of the MS Office applications that support VBA.
Code Notes
- The Fisher-Yates shuffle applies a pseudo random selection method. It is described here for characters in a string but a related method, the Durstenfeld-Knuth method is preferred for arrays.
- Taking each element of a string in sequence for repositioning leaves one end of the result string badly biased. The Knuth algorithm instead proposes a random position within the string. The element at that position is then accumulated into the output and removed from the original. Subsequent selections are made in the same way from the ever shortened string.
- Note that there is still the possibility of a given character being unmoved in the process, but only within expectation.
- Set the number of strings required with variable Cycles in the top procedure. The Immediate Window has proved the best place for display and copying.
- It should be pointed out that any attempt to avoid the unmoved elements, will not only change the random nature of the shuffle but prevent the use of other than non-repeat strings. That is to say strings with repeated characters could not then be shuffled.
- The Durstenfeld-Knuth method for arrays differs only slightly from that of the Fisher-Yates implementation.
- To reduce processing, and no doubt to overcome the burden of removing an element from the middle of an array during shortening, the algorithm instead overwrites the element selected for output with the last element. In this VBA implementation the array is then conveniently shortened by one element with Redim Preserve.
- See Fisher Yates Shuffle for a good description of both methods.
The VBA Code Module
Copy all of the code below into say, an MS Excel standard module, save the workbook as an xlsm file type, and run either of the test procedures to test the requisite code. Be sure to open the Immediate Window for output.
Option Explicit
Private Sub testFisherYatesStrShuffle()
'run this to test the string shuffle
Dim bOK As Boolean, sStr As String, sR As String
Dim sOut As String, n As Long, Cycles As Long
'set number of shuffled versions needed
Cycles = 1
'test string
sStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
For n = 1 To Cycles
bOK = FisherYatesStrShuffle(sStr, sR)
sOut = sR
If bOK = False Then
MsgBox "Problems in shuffle"
Exit Sub
End If
'output to message box and immediate window
'MsgBox "Before : " & sStr & vbCrLf & _
"After : " & sR
Debug.Print "Before : " & sStr
Debug.Print "After : " & sOut & vbCrLf
Next n
End Sub
Private Function FisherYatesStrShuffle(ByVal sIn As String, sOut As String) As Boolean
'Performs a naive Fisher-Yates shuffle on the input string.
'Returns result in sOut. Pseudo random character sequencing.
'Note: Some or all elements could occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This can be seen best for very short character strings, like "ABC".
Dim sL As String, sR As String, sT1 As String, sT2 As String, sMod As String
Dim sAcc As String, i As Long, j As Long, nL As Long, n As Long
'check input string
If sIn = "" Or Len(sIn) < 2 Then
MsgBox "At least 2 characters needed - closing"
Exit Function
End If
'initial assignments
nL = Len(sIn)
sMod = sIn
Randomize
For i = 1 To Len(sIn)
'first get a random number
j = Int((nL - 1 + 1) * Rnd + 1)
'find string value of jth element
sT1 = Mid$(sMod, j, 1)
DoEvents 'allow break
'accumulate jth element
sAcc = sAcc & sT1
'remove current character
sL = Left$(sMod, j - 1)
sR = Right$(sMod, nL - j)
sMod = sL & sR
'new string length
nL = Len(sMod)
DoEvents 'allow break
Next i
'transfer
sOut = sAcc
FisherYatesStrShuffle = True
End Function
Private Sub testKnuthArrShuffle()
'run this to test the array shuffle
Dim bOK As Boolean, sStr As String, sOut As String
Dim Cycles As Long, n As Long, bF As Boolean
Dim vS As Variant, vA As Variant, vB As Variant
'define a typical array for shuffling
vS = 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")
'set number of shuffled versions needed
Cycles = 1
For n = 1 To Cycles
'shuffle array
bOK = KnuthArrShuffle(vS, vA)
If bOK = False Then
MsgBox "Problems in array shuffle"
Exit Sub
End If
'arrays to strings for display
sStr = Arr1DToStr2(vS)
sOut = Arr1DToStr2(vA)
'display
' MsgBox "Before : " & sStr & vbCrLf & _
' "After : " & sOut
Debug.Print "Before : " & sStr
Debug.Print "After : " & sOut & vbCrLf
'return to an array in vB if needed
bF = StrTo1DArr2(sOut, vB)
Next n
End Sub
Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
' Performs a modified Knuth random shuffle on the elements of the input array.
' The original by Fisher-Yates, was modified for computers by Durstenfeld
' then popularised by Knuth. Returns result in vR with vIn unchanged.
'Note: Some or all elements COULD occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This is best seen for small arrays, say with only 3 elements or so.
Dim vW As Variant
Dim LB As Long, UB As Long, nL As Long
Dim i As Long, j As Long
'initial assignments
LB = LBound(vIn): UB = UBound(vIn)
ReDim vR(LB To UB) 'return array
ReDim vW(LB To UB) 'work array
nL = UB - LB + 1 'length of input array
vW = vIn 'transfer to a work array
'working
Randomize
For i = LB To nL
'first get a random number
j = Int((UB - LB + 1) * Rnd + LB)
'transfer jth of vW to ith of vR
vR(i) = vW(j)
'replace selection with current last of vW
vW(j) = vW(UB)
'remove last of vW by shortening array
ReDim Preserve vW(LB To UB - 1)
'get new UBound of shortened vW
UB = UBound(vW)
'exception; return if last chara
If UB = LB Then
vR(i + 1) = vW(UB)
Exit For
End If
DoEvents 'allow breaks
Next i
KnuthArrShuffle = True
End Function
Function StrTo1DArr2(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
StrTo1DArr2 = True
End Function
Function Arr1DToStr2(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
Arr1DToStr2 = sAccum
End Function
See Also
- Fisher Yates Shuffle: A very clearly written article in Wikipedia, that explains worked examoles step by step.
External Links
Compare Shuffle Methods for Bias
Summary
This VBA code module shows how bias can affect a shuffle algorithm, even when a random generator is used. The module is intended for MS Excel and prints two statistics panels on the worksheet to show how the selected methods differ. The good version is the Knuth shuffle algorithm, and the other is one that makes methodical swaps, sometimes multiple swaps, throughout the length of the array.
Notes on the code
- Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.
- The shuffle algorithms run for many cycles, (user set), and the bin count of discrete outcomes is presented in statistics. Notice that a very small number of elements, (3 or 4), has been used to keep the display and run time manageable. It may be of interest to know that the number of discrete outcome combinations is equal to the factorial of the number of elements. That is; using just six elements, say A,B,C,D,E,and F, would result in 6! = 120 discrete combinations, and a corresponding increase in the time to run.
- In particular, it should be noted that a small coefficient of variation (CV) denotes a method that is close to random whereas one with a higher CV shows that there is bias in the method.
- The method that uses multiple swaps is biased, whereas the Knuth method is not.
VBA Code Module
Option Explicit
Option Base 1
Private Sub RunShuffleBiasDemo()
'Run this to compare the bias for shuffling
'character arrays using two methods.
'Note large sets are too time consuming,
'since there are n! combinations.
'THIS SUB CLEARS AND WRITES TO SHEET1
Dim vArr As Variant, vRet As Variant
Dim nT As Long, bOK As Boolean, vT As Variant
Dim nCycles As Long, n As Long, sT As String
'load a typical 1D data array with test data
'3 elements makes 3! = 6 bins
'4 elements needs 4! = 24 bins etc.
vArr = Array("A", "B", "C")
'set number of cycles for test
'Typical time to complete 3 element test:
'25 secs for 100000 cycles
'225 secs for 1000000 cycles
nCycles = 100000
'dimension the collection array
ReDim vT(1 To nCycles)
'clear the worksheet
ClearWorksheet "Sheet1", 3 'contents and formats
'runs number of shuffle samples
For n = 1 To nCycles
'give way to commands-eg; break
DoEvents
'pass array to a random shuffling proc
bOK = KnuthArrShuffle(vArr, vRet)
'make a single string from array elements
sT = Arr1DToStr(vRet)
'save shuffle instance in an array
vT(n) = sT
Next n
'pass array to the proc with label for the display
CountUniqueArrayValues2 vT, 2, 2, "Test Set: Rnd Knuth"
'run a number of shuffle samples
For n = 1 To nCycles
'give way to commands-eg; break
DoEvents
'pass array to a random shuffling proc
bOK = BiasedMultiSwapArrShuffle(vArr, vRet)
'make a single string from array elements
sT = Arr1DToStr(vRet)
'save shuffle instance in an array
vT(n) = sT
Next n
'pass array to the proc with label for the display
CountUniqueArrayValues2 vT, 2, 7, "Test Set: Rnd Biased?"
'report end
MsgBox "Display done."
End Sub
Private Sub CountUniqueArrayValues2(vI As Variant, Optional nRow As Long = 1, _
Optional nCol As Long = 1, Optional sLabel As String = "")
'Counts instances of data number values in vI. Generates various stats
'for the bin quantities.
'THIS SUB CLEARS AND WRITES TO SHEET1
Dim vRV As Variant, vRQ As Variant, vDS As Variant
Dim LB As Long, UB As Long, vDB As Variant
Dim n As Long, bOK As Boolean
'make bins and count contents
bOK = DiscreteItemsCount(vI, vRV, vRQ)
LB = LBound(vRV, 1): UB = UBound(vRV, 1)
ReDim vDS(1 To 12, 1 To 3)
ReDim vDB(LB To UB + 2, 1 To 3)
If bOK Then 'load bins and stats arrays
vDB(1, 1) = sLabel: vDB(1, 2) = "Value": vDB(1, 3) = "Quantity"
For n = LB To UB
DoEvents
vDB(n + 2, 1) = "Bin # " & n 'headings
vDB(n + 2, 2) = vRV(n) 'value
vDB(n + 2, 3) = vRQ(n) 'quantity
Next n
On Error Resume Next 'avoids Mode() error when no value stands out
With Application.WorksheetFunction
vDS(1, 1) = sLabel: vDS(1, 2) = "": vDS(1, 3) = "Quantity"
vDS(3, 1) = "Average": vDS(3, 3) = Format(.Average(vRQ), "#0.000")
vDS(4, 1) = "Median": vDS(4, 3) = .Median(vRQ)
vDS(5, 1) = "Mode": vDS(5, 3) = .Mode(vRQ)
vDS(6, 1) = "Minimum": vDS(6, 3) = .Min(vRQ)
vDS(7, 1) = "Maximum": vDS(7, 3) = .Max(vRQ)
vDS(8, 1) = "Std.Deviation": vDS(8, 3) = Format(.StDevP(vRQ), "#0.000")
vDS(9, 1) = "StDev/Av %": vDS(9, 3) = Format(.StDevP(vRQ) * 100 / .Average(vRQ), "#0.000")
vDS(10, 1) = "Variance": vDS(10, 3) = Format(.VarP(vRQ), "#0.000")
vDS(11, 1) = "No.Unique Values": vDS(11, 3) = UBound(vRQ) - LBound(vRQ) + 1
vDS(12, 1) = "No.Samples": vDS(12, 3) = UBound(vI) - LBound(vI) + 1
End With
Err.Clear
Else
MsgBox "Problems getting bin count - closing"
Exit Sub
End If
'output to sheet
'ClearWorksheet "Sheet1", 3 'clear both contents and formats of the worksheet
Array2DToSheet vDS, "Sheet1", nRow, nCol 'transfer stats panel to sheet with top left at row2, col2
Array2DToSheet vDB, "Sheet1", nRow + 13, nCol 'transfer bins panel to sheet with top left below stats
FormatCells "Sheet1" 'apply font and autofit formats to all cells of the worksheet
End Sub
Private Function DiscreteItemsCount(vIn As Variant, vRetV As Variant, vRetQ As Variant) As Boolean
'Counts number of repeats of element values found in vIn
'Returns with one column for each unitque value and quantity found.
'Returns as 2D vRet, unsorted; row1=input value, row2=item count.
Dim vA As Variant, vTS As Variant, vTB As Variant
Dim s As Long, b As Long, n As Long, bFound As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
Dim LBS As Long, UBS As Long
'dimension 2D work array
ReDim vA(1 To 2, 1 To 1)
'get source 1D array bounds
LBS = LBound(vIn): UBS = UBound(vIn)
'get work array bounds
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
'intitial values
s = LBS
b = 0
vA(2, 1) = 0
Do 'step through store
DoEvents
'get source element value
vTS = vIn(s)
'check bins
Do
DoEvents
b = b + 1
'get bin element value
vTB = vA(1, b)
If vTS = vTB Then 'found in bins
vA(2, b) = CLng(vA(2, b)) + 1 'update bin
bFound = True
End If
Loop Until b >= UB2 Or bFound = True
If bFound = False Then 'no such bin exists yet
'not found in bins
If vA(2, UB2) <> 0 Then 'first element been used
ReDim Preserve vA(LB1 To UB1, LB2 To UB2 + 1)
UB2 = UBound(vA, 2)
End If
'update new bin
vA(1, UB2) = vTS
vA(2, UB2) = 1
bFound = True
End If
'reset loop variables
bFound = False
b = 0
s = s + 1
Loop Until s > UBS
'transfers -need to be separate for other uses
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
ReDim vRetV(LB2 To UB2) 'contains values
ReDim vRetQ(LB2 To UB2) 'contains quantities
For n = LB2 To UB2
vRetV(n) = vA(1, n)
vRetQ(n) = vA(2, n)
Next n
For n = LB2 To UB2
Debug.Print vRetV(n) & vbTab & vRetQ(n)
Next n
Debug.Print vbCrLf
DiscreteItemsCount = True
End Function
Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
'clears worksheet contents, formats, or both
'but does not remove charts from the worksheet
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Sub
End Select
End With
oWSht.Cells(1, 1).Select
End Sub
Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'modify end point for parameter starting values
nNewEndR = nRows + nStartRow - 1
nNewEndC = nCols + nStartCol - 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = vIn
End Sub
Private Sub FormatCells(sSht As String)
' Applies certain formats to all cells
' of the named parameter worksheet
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
oSht.Activate
'format all cells of the worksheet
oSht.Cells.Select
With Selection
.Font.Name = "Consolas" 'mono
.Font.Size = 14
.Columns.AutoFit
.Rows.AutoFit
.HorizontalAlignment = xlLeft 'xlRight 'xlCenter
.VerticalAlignment = xlBottom 'xlCenter 'xlTop
End With
oSht.Range("A1").Select
End Sub
Private Function KnuthArrShuffle(vIn As Variant, vR As Variant) As Boolean
' Performs a modified Knuth random shuffle on the elements of the input array.
' The original by Fisher-Yates, was modified for computers by Durstenfeld
' then popularised by Knuth. Returns result in vR with vIn unchanged.
'Note: Some or all elements COULD occupy their original positions,
'but only in accordance with expectation based on the random generator.
'This is best seen for small arrays, say with only 3 elements or so.
Dim vW As Variant
Dim LB As Long, UB As Long, nL As Long
Dim i As Long, j As Long
'initial assignments
LB = LBound(vIn): UB = UBound(vIn)
ReDim vR(LB To UB) 'return array
ReDim vW(LB To UB) 'work array
nL = UB - LB + 1 'length of input array
vW = vIn 'transfer to a work array
'working
Randomize
For i = LB To nL
'first get a random number
j = Int((UB - LB + 1) * Rnd + LB)
'transfer jth of vW to ith of vR
vR(i) = vW(j)
'replace selection with current last of vW
vW(j) = vW(UB)
'remove last of vW by shortening array
ReDim Preserve vW(LB To UB - 1)
'get new UBound of shortened vW
UB = UBound(vW)
'exception; return if last chara
If UB = LB Then
vR(i + 1) = vW(UB)
Exit For
End If
DoEvents 'allow breaks
Next i
KnuthArrShuffle = True
End Function
Private Function BiasedMultiSwapArrShuffle(vIn As Variant, Optional vRet As Variant) As Boolean
'Performs a random shuffle on input array strings.
'Input parameter is a single array. Returns in single vRet
'if provided, else in vIn modified. Multiple shuffles applied.
'Displays more bias than the Knuth method.
Dim vR As Variant
Dim sT As String, sTJ As String, sTS As String, nC As Long
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
Dim i As Integer, j As Long, bSUsed As Boolean, bRUsed As Boolean
'get dimensions of vIn
LB1 = LBound(vIn): UB1 = UBound(vIn)
'dimension a work array
ReDim vR(LB1 To UB1)
'load local array
For i = LB1 To UB1
DoEvents
vR(i) = vIn(i)
Next i
'get dimensions of vR
LB2 = LBound(vR): UB2 = UBound(vR)
'randomize the rnd generator
Randomize
For i = LB2 To UB2
DoEvents
'get rnd number
j = Int((UB2 - LB2 + 1) * Rnd + LB2)
'exchange elements
sT = vR(i) 'swap
vR(i) = vR(j)
vR(j) = sT
Next i
'transfers
If Not IsMissing(vRet) Then
ReDim vRet(LB2 To UB2)
For i = LB2 To UB2
DoEvents
vRet(i) = vR(i)
Next i
Else
For i = LB2 To UB2
DoEvents
vIn(i) = vR(i)
Next i
End If
'return status
BiasedMultiSwapArrShuffle = True
End Function
Private 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
DoEvents
sT = vIn(nC)
sAccum = sAccum & sT
Next
Arr1DToStr = sAccum
End Function
See Also
Backup Text Boxes on Close
Summary
This VBA code is written for Microsoft Excel but is easily adapted to other applications in the MS Office set. It saves all of the text from a user form's text boxes in a log file whenever the form is closed. Then later, on re-opening the form, or at any other time, the user can fill the boxes with the most recent saved text.
The VBA Code
- The code needs a user form called Userform1, two text boxes, TextBox1 and TextBox2, and a command button called CommandButton1. Set the UserForm1 property ShowModal to false for convenient study. Copy the code below into the three respective modules and save the workbook with an xlsm file suffix.
- Any code that is found in text boxes will be saved when the user form closes. This includes inadvertent closure of the user form or the deliberate closing of the workbook. It does not of course protect against the effect of power failures. The saving of data happens without intervention, so may need consideration if the storage of sensitive data is to be avoided.
- The log file is called SavedText.txt, and will be found in the same folder as the workbook. If a log file of that name is not found, then it will be made by the code for use. The log file has only two fields, the text box name and the string contents found in it. The comma separator was avoided in favor of the less likely encountered string >Break<.
- The saving function runs from the UserForm_QueryClose event. SaveTextBoxes() makes a log string in a userform controls loop, then exports the string via WriteToFile().
- WriteToFile() makes a log file if it does not exist, but otherwise overwrites any text that it finds, so that only the most recently saved session will be found there. Users who employ the logging procedure elsewhere should note that an extra Cr and Lf are stored at the end of logged entries, and might need consideration.
- RestoreTextBoxes() runs only by pressing CommandButton1, so the user chooses whether or not to insert text. GetAllFileText() imports all of the log file's contents at once with the file retaining contents until it is next overwritten. The string is split twice, once to break it into lines, that is, one for each text box record, and then again to break each record into its two fields for matching control names in the main transfer loop.
Code Changes
8 March 2019: Changed data separator from comma to other, in Standard Module
For the ThisWorkbook Module
'...............................................
' Notes: Code needs a user form named UserForm1,
' with two text boxes, TextBox1 and Textbox2,
' and a command button with name CommandButton1.
' Set UserForm1 property ShowModal to False
'...............................................
Private Sub Workbook_Open()
'Runs on opening the workbook
Load UserForm1
UserForm1.Show
End Sub
For the Userform1 Module
Private Sub CommandButton1_Click()
' Restores saved textbox text
' after reopening the user form
' restores textbox text from file
RestoreTextBoxes
'set insertion point to TextBox1
With TextBox1
.SelStart = Len(.Value) 'to end of text
.SelLength = 0 'just insertion
.SetFocus
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' Runs before closing the userform
' Used here to save textbox values in a log file
SaveTextBoxes
End Sub
For the Standard Module
Option Explicit
Sub SaveTextBoxes()
' Saves values from user form text boxes to a log file
' Data is never lost while log file exists
' Runs in the UserForm_QueryClose() event at all times.
Dim oForm As UserForm, oCont As Control, sStringOut As String
Dim bCont As Boolean, sPath As String, sLogPath As String
Dim sType As String
Set oForm = UserForm1
sPath = Application.ThisWorkbook.Path
sLogPath = sPath & "\" & "SavedText.txt" 'log file address
sType = "TextBox"
'step through the form controls to find the textboxes
For Each oCont In oForm.Controls
If TypeName(oCont) = sType Then
sStringOut = sStringOut & oCont.Name & ">Break<" & oCont.Value & vbCrLf
End If
Next oCont
'remove tailend Cr and Lf
sStringOut = Left$(sStringOut, Len(sStringOut) - 2)
'send textbox string to the log file
WriteToFile sStringOut, sLogPath
'release object variables
Set oForm = Nothing
Set oCont = Nothing
End Sub
Function WriteToFile(ByVal sIn As String, ByVal sPath As String) As Boolean
' REPLACES all content of a text file with parameter string
' Makes the file if it does not exist
' Assumes that all formatting is already in sIn
' Note that this log file will add Cr and Lf to the stored string
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
Sub RestoreTextBoxes()
' Restores saved values to user form text boxes.
' Data is never lost while log file exists.
' Runs when CommandButton1 is pressed
Dim oCont As Control, oForm As UserForm
Dim vA As Variant, vB As Variant, sRet As String
Dim sPath As String, sLogPath As String, nC As Long
Set oForm = UserForm1
sPath = Application.ThisWorkbook.Path
sLogPath = sPath & "\" & "SavedText.txt"
'get text from the log file
GetAllFileText sLogPath, sRet
'remove the extra Cr and Lf added by the log file
sRet = Left(sRet, Len(sRet) - 2)
'step through controls to match up text
vA = Split(sRet, vbCrLf)
For nC = LBound(vA, 1) To UBound(vA, 1)
'MsgBox Asc(vA(nC))
vB = Split(vA(nC), ">Break<")
For Each oCont In oForm.Controls
If oCont.Name = vB(0) Then
oCont.Value = vB(1)
End If
Next oCont
Next nC
'release object variables
Set oForm = Nothing
Set oCont = Nothing
End Sub
Function GetAllFileText(ByVal sPath As String, sRet As String) As Boolean
' Returns entire log file text in sRet
' Note that this log file will add Cr and Lf to the original string
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
See Also
External Links
Block Illegal Characters
Summary
This VBA example can be run in any of the commonly used Microsoft Office applications. The examples show how to exclude illegal characters from text boxes while the keys are being pressed. In each of the two examples, the insertion point simply remains where it was when an illegal character is entered; accepted characters appear in the usual way. Both examples make use of the TextBox_KeyPress event; then first accepting only integers and a few other characters, and the second only letters and some supporting characters.
The VBA Code
For the ThisWorkbook Module
'...............................................
' Notes: Code needs a user form named UserForm1,
' with two text boxes, TextBox1 and Textbox2,
' and a command button with name CommandButton1.
' Set UserForm1 property ShowModal to False
'...............................................
Private Sub Workbook_Open()
'Runs on opening the workbook
Load UserForm1
UserForm1.Show
End Sub
For the UserForm1 Module
- Make sure that the ShowModal property of the user form is set to False, to allow normal code working and study with an open form.
- Copy the code below into the UserForm1 module, and type text into the boxes to see the results.
- Setting the parameter KeyAscii in code to the ASCI value of a non-printing character (eg: zero), prevents the display of the character that originated the event. Otherwise, KeyAscii is found to contain the ASCI value of the key that was pressed, and it is displayed.
- The KeyAscii value can be changed to any asci value, and provided that it is a printing character, it will be displayed.
- In each case code is added to restrict the permitted positions in the text. For example, a minus sign is valid only at the start of a number, and a hyphen is never expected at the start of a word.
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Block character input other than integers, minus signs, and periods
'For example, to enter a number and decimal, eg; -4756.09
Select Case KeyAscii
'accept integers
Case Asc("0") To Asc("9")
Case Asc("-") ' unless one already exists or cursor not at start
If InStr(1, Me.TextBox1.Text, "-") > 0 Or Me.TextBox1.SelStart > 0 Then
KeyAscii = 0 'return a non-printing character
End If
Case Asc(".") 'unless one exists already
If InStr(1, Me.TextBox1.Text, ".") > 0 Then
KeyAscii = 0 'return a non-printing character
End If
Case Else
KeyAscii = 0 'return a non-printing character
End Select
End Sub
Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Block character input other than letters, hyphens, periods, and space
' For example, for title, forename and surname, eg; Mr. John Doe.
Select Case KeyAscii
'accept upper and lower case letters
Case Asc("a") To Asc("z"), Asc("A") To Asc("Z")
Case Asc("-"), Asc("."), Asc(" ")
'ok provided on at least the third character
If Me.TextBox2.SelStart < 2 Then 'zero is first
KeyAscii = 0 'return a non-printing character
End If
Case Else
KeyAscii = 0 'return a non-printing character
End Select
End Sub
See Also
External Links
Validate with the Like Operator
Summary
This VBA example can be run in any of the commonly used Microsoft Office applications. The examples on this page make use of the Like operator to compare strings. The first example shows how to check that a string conforms to the correct format of the United Kingdom's National Insurance Number (NINO), a number used in much the same way as the US Social Security Number (SSN). The rules for the format are clear so it makes a good example. Unlike examples elsewhere in this set that check for illegal characters while they are being entered, this method is carried out only when the user has completed the entry.
The VBA Code
- The code needs a user form called Userform1, two text boxes, TextBox1 and TextBox2, and a command button called CommandButton1. Set the UserForm1 property ShowModal to false for convenient study. Copy the code below into the three respective modules and save the workbook with an xlsm file suffix.
- When the workbook is opened, the user form will be displayed. Type a number format into TextBox1 and when complete, press the tab key to move to the next textbox. If the number format is correct then the insertion point will move, but if not it will stay in the faulty text ready for correction. Setting the Cancel argument of BeforeUpdate() to true prevents the move.
- Note that the Before_Update() event will not run at all unless a change has been made the text since the last time that the insertion point entered the box. So, to labor the point, after leaving the box, if the user clicks in it again without changes, the event does not run when moving on. If this poses a problem then consider the use of the Exit event for testing.
- See also Input Boxes for a number of other validation-related procedures.
Code Changes
There are no changes so far.
For the ThisWorkbook Module
Private Sub Workbook_Open()
' Runs when workbook opens
Load UserForm1
UserForm1.Show
End Sub
For the UserForm1 Module
Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
'Runs on exit from the textbox provided that changes to text were made.
'Setting Cancel to True keeps the insertion point in the text
'instead of tabbing on.
If IsNINO(TextBox1.Value) Then
'all ok
Else
Cancel = True
End If
End Sub
For the Standard Module
Sub testIsNINO()
'run this to test the IsNINO procedure
Dim sIn As String
'set nino here to test
sIn = "QQ123456A"
MsgBox IsNINO(sIn)
End Sub
Function IsNINO(sIn As String) As Boolean
' Checks format of UK National Insurance Number (NINO)
' Converts to upper case for comparison
'NOTES: Ref:National Insurance Numbers (NINOs): Format and Security:
' https://www.gov.uk/hmrc-internal-manuals/national-insurance-manual/nim39110
'A NINO is made up of two letters, six numbers and a final letter, which is always A, B, C, or D.
'D, F, I, Q, U, and V are not used as first or second letter of prefix.
'Letter O is not used as the second letter of prefix.
'Prefix combinations BG, GB, KN, NK, NT, TN and ZZ are not to be used.
'Suffix characters can be only A,B, C,or D. (Elsewhere in examples space has been included here.)
Dim bTemp As Boolean
Const s1 As String = "[ABCEGHJKLMNOPRSTWXYZ]" 'alphabet less D, F, I, Q, U, and V; pattern for the first letter
Const s2 As String = "[ABCEGHJKLMNPRSTWXYZ]" 'alphabet less D, F, I, O , Q, U, and V; pattern for the second letter
Const s3 As String = "######" 'includes only six integers; pattern for the six integers
Const s4 As String = "[ABCD]" 'includes only A, B, C, or D; pattern for the end letter
' Four parts of number to check are each in square brackets
' Right hand side of like operation concatenates
' all four pattern strings as one. Notice that the alpha patterns here make
' use of long format notation where every character permitted has been included.
' Instead, the alpha patterns could have been expressed as ranges; eg; "[ABCD]" is same as "[A-D]"
bTemp = UCase(sIn) Like s1 & s2 & s3 & s4
If bTemp Then
' Check for illegal pairs
Select Case Left$(UCase(sIn), 2)
Case "BG", "GB", "KN", "NK", "NT", "TN", "ZZ"
IsNINO = False
MsgBox "Illegal prefix pair detected."
Exit Function
Case Else
IsNINO = True
Exit Function
End Select
Else
MsgBox "Illegal characters detected."
IsNINO = False
Exit Function
End If
End Function
See Also
External Links
Delays Past Midnight
Summary
This VBA module delays for a specified number of seconds. It will work in any MS Office application that can run VBA. The following points are worth noting:
- Most delay procedures have problems at midnight when the Timer function resets, so code that depends on the difference of two values that span that time will be in error, and will perhaps cause a failure. This procedure avoids such problems by also compensating for the number of lapsed days. As such it will be found useful in timing and clock applications, if not for measuring time, at least for deciding when the display is to be updated. For example; running a delay of twenty seconds from ten seconds to midnight (clock count 86390) to ten seconds after midnight (supposed clock count 86410) would reset at midnight, and would never reach the required end value. The problem is solved by adding one count of 86400 (the number of seconds in one day) to the stepped value for each time that a date transition is made.
- The anticipated resolution of the procedure is about 10-16mS, consistent with that of the system timer. It is perhaps of interest to note that the GetTickCount API while able to accept millisecond parameters is still limited to the same 10-16mS resolution of the system timer.
- The procedure parameter can take on integers and fractions of a second, provided comments about resolution are borne in mind.
The Code
Copy the following VBA code into a standard module in Excel, Word, or any other Office application that supports VBA.
Option Explicit
Sub testDelay()
'tests delay procedure
MsgBox DelaySecs(1.1) 'seconds
End Sub
Function DelaySecs(nSecs As Single) As Boolean
'Delays for nSecs SECONDS.
'Avoids midnight reset problem.
'Typical resolution 10-16mS.
Dim StartDate As Date
Dim StartTime As Single
Dim TimeNow As Single
Dim Lapsed As Single
'get launch date and current timer
StartTime = Timer
StartDate = Date
'then loop until lapse of parameter time
Do
DoEvents 'allow form updates and breaks
'86400 seconds per new day
TimeNow = 86400 * (Date - StartDate) + Timer
Lapsed = TimeNow - StartTime
Loop Until Lapsed >= nSecs
'MsgBox Lapsed
DelaySecs = True
End Function
See Also
- Wait Functions - Chip Pearson: Several other methods of delay are considered.
Time Lapsed Between Dates
Summary
This module contains VBA code to calculate the lapsed time between two fully expressed dates; that is, containing both date and time information. It can run in any MS Office applications like Excel that can run VBA code.
- This procedure shows how to extract integer values of the time components from a date variable rather than the more usual string representation of a date. That is to say, assuming that the difference between two dates is two days, to extract the integer two instead of some date string for the year 1900.
- Date variables contain a combination of both dates and times, but they need not do so. Some have only dates and some have only times, and when converted to the single data type, they can be seen to represent days in their integer parts and times in their fractions. Although the input parameters can contain any date variables, exact results are obtained only when both times and dates are included in each parameter. If time data is missing from a date, the calculation is still performed but uses midnight as the assumption.
- The integer part of a date-converted-to-single is just the number of days since 31 Dec 1899 . It follows then that negative integer parts describe the days before that reference date. In fact the date function can be used for dates in the Gregorian calendar from Aug 2, 718 through Dec 31, 9999, though this differs when other calendars are in use. Add integers to, or subtract integers from date variables to modify the date by that number of days. Subtraction also applies.
- The fractional part of a date represents a part of a day. The individual parts of time within it can be obtained as follows; multiply the date variable by 86400 to find the whole-seconds; by 1440 for whole-minutes; and by 24 for whole-hours. Then convert these results to the single data type before taking each integer part. To modify an existing date variable by a number of seconds, we simply add 1/86400 to it for each second; 1/1440 per minute, 1/24 per hour, and as stated earlier, whole units for days. Subtraction also applies.
- Various functions also exist to simplify date-time handling.
The Code Module
Copy all of the VBA code below into a standard module.
- Run the top procedure to test the function. Two examples are given; one for exact date-time data and another where some time data is missing.
- The output result is a colon-separated string, containing any of a selection of formats; seconds only, minutes-seconds, hours-minutes-seconds, or days-hours-minutes-seconds. The format option is set with sConfig, and the optional units label is returned in sLabel.
- The procedure's detail is useful. The procedure LapsedTime() illustrates the basics of multi-component extraction, as compared to the use of the VBA DateDiff function's counting intervals of one type.
Option Explicit
Sub testLapsedTime()
'Run this to test LapsedTime()
'For both fully expressed and
'partially expressed date-times
Dim dDateTimeStart As Date
Dim dDateTimeEnd As Date
Dim sOut As String, sLab As String
'EXACT LAPSED TIME FOR TWO DATE-TIME VALUES
'set two exact date-times for calculation
dDateTimeStart = #1/5/2019 1:20:10 PM# '
dDateTimeEnd = #1/7/2019 2:37:20 PM#
'exactly 2 days, 1 hours, 17 mins, and 10 seconds apart
sOut = LapsedTime(dDateTimeEnd, dDateTimeStart, "dhms", sLab)
MsgBox "Exact Lapsed Time:" & vbCrLf & "For fully expressed date-times:" & vbCrLf & vbCrLf & _
Format(dDateTimeEnd, "mmm dd yyyy" & ", hh:mm:ss") & " End Time" & vbCrLf & _
Format(dDateTimeStart, "mmm dd yyyy" & ", hh:mm:ss") & " Start Time" & vbCrLf & vbCrLf & _
sOut & " , " & sLab
'WITH SOME TIME INFO MISSING - DEFAULTS TO MIDNIGHT
'set the incomplete date-times for calculation
'first item has no time data so DEFAULTS TO MIDNIGHT
dDateTimeStart = #1/5/2019# 'assumes time 0:0:0
dDateTimeEnd = #1/7/2019 2:37:20 PM#
'default time given as 2 days, 14 hours, 37 mins, and 20 seconds apart
sOut = LapsedTime(dDateTimeEnd, dDateTimeStart, "dhms", sLab)
MsgBox "Default value of Lapsed Time:" & vbCrLf & "When time data is missing," & vbCrLf & _
"midnight is assumed:" & vbCrLf & vbCrLf & _
Format(dDateTimeEnd, "mmm dd yyyy" & ", hh:mm:ss") & " End Time" & vbCrLf & _
Format(dDateTimeStart, "mmm dd yyyy") & " Start Time" & vbCrLf & "becomes " & vbCrLf & _
Format(dDateTimeStart, "mmm dd yyyy" & ", hh:mm:ss") & " Start Time" & vbCrLf & vbCrLf & _
sOut & " , " & sLab
End Sub
Function LapsedTime(dTimeEnd As Date, dTimeStart As Date, _
sConfig As String, Optional sLegend As String) As String
'Returns difference of two dates (date-times) in function name.
'Choice of various colon-separated outputs with sConfig.
'and Optional format label found in string sLegend
Dim sOut As String
Dim dDiff As Date
'Parameter Options for sConfig
' "s" output in seconds. Integer.
' "ms" output in minutes and seconds. mm:ss
' "hms" output in hours, minutes and seconds. hh:mm:ss
' "dhms" output in days, hours, minutes and seconds. integer:hh:mm:ss
'test parameters
If Not IsDate(dTimeStart) Then
MsgBox "Invalid parameter start date - closing."
ElseIf Not IsDate(dTimeEnd) Then
MsgBox "Invalid parameter end date - closing."
Exit Function
End If
'difference as date-time data
dDiff = dTimeEnd - dTimeStart
'choose required output format
Select Case sConfig
Case "s" 'output in seconds.
sOut = Int(CSng(dDiff * 24 * 3600))
sLegend = "secs"
Case "ms" 'output in minutes and seconds
sOut = Int(CSng(dDiff * 24 * 60)) & ":" & Format(dDiff, "ss")
sLegend = "mins:secs"
Case "hms" 'output in hours, minutes and seconds
sOut = Int(CSng(dDiff * 24)) & ":" & Format(dDiff, "nn:ss")
sLegend = "hrs:mins:secs"
Case "dhms" 'output in days, hours, minutes and seconds
sOut = Int(CSng(dDiff)) & ":" & Format(dDiff, "hh") _
& ":" & Format(dDiff, "nn") & ":" & _
Format(dDiff, "ss")
sLegend = "days:hrs:mins:secs"
Case Else
MsgBox "Illegal format option - closing"
Exit Function
End Select
LapsedTime = sOut
End Function
See Also
- Calculate Elapsed Time - Microsoft: An article by Microsoft describing methods of avoiding error in time comparisons.
Date-Time String Formats
Summary
This page lists VBA code to format date-time strings and intervals. It is for use in Microsoft Excel and similar applications that run VBA code. The procedure takes a date variable and returns it as a formatted string. The parameter nOpt sets the chosen format from a set that includes dates, times, or intervals. There are two main format types in use:
- Strings containing a date, are those that display a day, month, and year, with or without times added to them. The important point here is that the number of days stored in the date variable is intended to be displayed as a date, as opposed to an integer. For example, the integer stored for 25 December 2018 is just 43459 and is only converted for display. Nearly all of the format options in the code module are of this basic type.
- Strings containing time intervals, are intended to display the number of days as an integer, as opposed to displaying it as a conventional date; that is, in the format d:h:m:s, like a stopwatch. If a date format is selected for an intended for an interval of a couple of days or so, then a very early date near 1900 will be displayed. That said, such an error might still be useful for those curious about the actual number of days associated with a particular date. One time interval format has been included to illustrate the difference in the method, while a full set of these can be found on an adjacent page.
- Date-time variable assignment examples can be found in the procedure DateAssign().
VBA Code Module
Copy the entire VBA code listing into a standard module, select a formatting option (1-15) in the top procedure , then run it.
Modifications
- 10 Jan 2019, DateTimeFormat() code modified to include one interval format.
Option Explicit
Sub testDateFormats()
'Run this to format a date-time
Dim dDate As Date, nOpt As Integer
'set test date here - examples
dDate = #1/9/2019 1:45:02 PM#
'set format option 1-14 for dates
'and 15 to format as a time interval
nOpt = 14
MsgBox DateTimeFormat(dDate, nOpt)
End Sub
Function DateTimeFormat(dDate As Date, Optional ByVal nOpt As Integer = 1) As String
'Returns dDate as a date-time display string in function name.
'Optional format choice with nOpt= (1-14) for dates, and nOpt=(15) for intervals.
Dim sOut As String
If Not IsDate(dDate) Then
MsgBox "Parameter not a date - closing"
Exit Function
End If
Select Case nOpt 'returns for #1/9/2019 1:45:02 PM#
'(9th January 2019 at 13:45:02)
Case 1
sOut = Format(dDate, "dd\/mm\/yy") '09/01/19
Case 2
sOut = Format(dDate, "d mmm yy") '9 Jan 19
Case 3
sOut = Format(dDate, "dd:mm:yy") '09:01:19
Case 4
sOut = Format(dDate, "d mmmm yyyy") '9 January 2019
Case 5
sOut = Format(dDate, "mmmm d, yyyy") 'January 9, 2019
Case 6
sOut = Format(dDate, "dddd, dd\/mm\/yyyy") 'Wednesday, 09/01/2019
Case 7
sOut = Format(dDate, "dddd, mmm d yyyy") 'Wednesday, Jan 9 2019
Case 8
sOut = Format(dDate, "dddd, d mmmm yyyy") 'Wednesday, 9 January 2019
Case 9
sOut = Format(dDate, "y") '9, day in year (1-365)
Case 10
sOut = sOut = Format(dDate, "h:m:s") '13:45:2 'no leading zeros
Case 11
sOut = Format(dDate, "h:m:s AM/PM") '1:45:2 PM 'no leading zeros
Case 12
sOut = Format(dDate, "hh:mm:ss") '13:45:02 'leading zeros added
Case 13
sOut = Format(dDate, "ddmmyy_hhmmss") '090119_134502, leading zeros added
Case 14
sOut = Format(dDate, "dddd, d mmmm yyyy, hh:mm:ss AM/PM") 'Wednesday, 9 January 2019, 01:45:02 PM
Case 15
sOut = Format(Int(CSng(dDate)), "###00") & ":" & Format(dDate, "hh:nn:ss") 'time interval format
Case Else
MsgBox "Option out of bounds in DateTimeFormat() - closing"
End Select
DateTimeFormat = sOut
End Function
Sub DateAssign()
'date-time assignment examples
Dim dD1 As Date, dD2 As Date, dD3 As Date
Dim dD4 As Date, dD5 As Date, dD6 As Date
Dim dD7 As Date, dD8 As Date, dD9 As Date
Dim dD10 As Date, dD11 As Date, dd12 As Date
'These three assignment methods are equivalent
'and will display 25 Dec 2018 only
dD1 = #12/25/2018# 'literal
dD2 = DateValue("25 Dec 2018") 'string
dD3 = DateSerial(2018, 12, 25) 'integer
'These three assignment methods are equivalent
'and will display 10:05:07 AM only
dD4 = #10:05:07 AM# 'literal
dD5 = TimeValue("10:05:07") 'string
dD6 = TimeSerial(10, 5, 7) 'integer
'These six combined methods are equivalent
'and will display 25 Dec 2018 10:05:07 AM
dD7 = #12/25/2018 10:05:07 AM#
dD8 = dD1 + dD4
dD9 = DateValue("25 dec 2018") + TimeValue("10:05:07")
dD10 = DateSerial(2018, 12, 23) + TimeSerial(58, 4, 67)
dD11 = dD1 + (0 / 1) + (10 / 24) + (5 / 1440) + (7 / 86400)
dd12 = DateValue("27 dec 2018") - (2 / 1) + (10 / 24) + (5 / 1440) + (7 / 86400)
'confirm equality of results in immediate window
Debug.Print CStr(dD7) = CStr(dD8)
Debug.Print CStr(dD8) = CStr(dD9)
Debug.Print CStr(dD9) = CStr(dD10)
Debug.Print CStr(dD10) = CStr(dD11)
Debug.Print CStr(dD11) = CStr(dd12)
Debug.Print dD1
Debug.Print dD4
Debug.Print dD7
MsgBox dD7
End Sub
Avoiding Change Event Recursion
Summary
- This VBA code is intended to run in Microsoft Office applications that can run macros, like Excel or Word.
- It provides two different examples of a text box change event, one for TextBox1 and another for TextBox2.
- It will be noted that on displaying the form and entering one character into TextBox1, the resulting number found there is about 290 or so; this is coded to show the number of iterations of the change event that have taken place.
- Doing the same in TextBox2 shows that there has been just one run of the event.
- The code of the TextBox2_Change event avoids multiple runs of the procedure, avoiding the possibility of false results in certain circumstances.
The VBA Code
Code Changes
For the ThisWorkbook Module
'...............................................
' Notes: Code needs a user form named UserForm1,
' with two text boxes, TextBox1 and Textbox2,
'...............................................
Private Sub Workbook_Open()
'Runs on opening the workbook
Load UserForm1
UserForm1.Show
End Sub
For the UserForm1 Module
Private Sub TextBox1_Change()
' This Change event runs about 294 times
' for each character entered
Static nC As Long
'yield to commands-just in case
DoEvents
'increment for each iteration
nC = nC + 1
'this line causes this procedure to run again
TextBox1.Value = nC
End Sub
Private Sub TextBox2_Change()
' This Change event runs only once
' for each character entered
Static nC As Long
Static bEnableEvents As Boolean
'yield to commands-just in case
DoEvents
' increment for each iteration
nC = nC + 1
' false to start then true after that
If bEnableEvents = True Then
Exit Sub
End If
bEnableEvents = True
' this runs only once
TextBox2.Value = nC
' reset flag
bEnableEvents = False
End Sub
See Also
External Links
CommandButton Toggle
Summary
This VBA code module is made for Microsoft Excel but is easily adapted for use in other Office applications that can run VBA with user forms:
- Two improved CommandButton_Click() procedures are provided. They show better emphasis when buttons are prssed. CmmandButton1_Click() has a toggle action, for example to set either one of two possible modes, and CommandButton2_Click() performs the usual task of one function. In each case:
- The user-set captions change in transition to reflect the current state of the buttons, for example Running etc. This can be of interest in the toggle states or when a procedure takes a long time to run.
- The button size is swelled about its center. This avoids enlargement from a fixed top-left point. The amount of the increase can be set within the procedure.
- The background and font color of the buttons are set in code, so are easily modified. Separate colors can be used for the two states.
- The Me.Repaint lines ensure that the button formats update immediately. If they are not present the procedures will start, and perhaps end, before that was done. Without Me.Repaint, but when DoEvents exists in the procedure-to-run, the repaint might still appear to work normally, until a procedure is run that does not require DoEvents. For those who intend to study this point, it is shown up best in the CommandButton2_Click() procedure.
The Code Module
Copy the UserForm_Initialize(), CommandButton1_Click(), and CommandButton2_Click() procedures into the UserForm module of an Excel project. This can be achieved by first inserting a form called UserForm1, with one CommandButton called CommandButton1 and another CommandButton2. Double-click within the form in design mode to access its module. The Workbook_Open() procedure goes into the ThisWorkbook module. Then, save the workbook, and run Workbook_Open() (or re-open the workbook) to test the buttons on the form.
Modifications
- 20 Jan 2019, added the previously omitted Me.Repaint code lines
Private Sub Workbook_Open()
'run this to show form
Load UserForm1
UserForm1.Show
End Sub
Option Explicit
Private Sub UserForm_Initialize()
With CommandButton1
.Height = 50
.Width = 50
.Caption = "Turn ON"
.BackColor = RGB(255, 205, 183)
End With
With CommandButton2
.Height = 50
.Width = 50
.Caption = "Turn ON"
.BackColor = RGB(255, 205, 183)
End With
End Sub
Private Sub CommandButton1_Click()
'TOGGLES caption, color and size-about-center
'of a typical CommandButton control, between
'say, two stable modes of working.
Dim nInc As Integer, n As Long
'set size increase (say 0 to 10)
nInc = 8
With CommandButton1
'run the OFF code
If .Caption = "Turn OFF" Then
.Width = .Width - nInc
.Height = .Height - nInc
.Caption = "Turn ON"
.Left = .Left + nInc / 2
.Top = .Top + nInc / 2
.BackColor = RGB(255, 205, 183)
.ForeColor = RGB(0, 0, 0)
Me.Repaint 'redraw form
'add procedure here for the OFF state
'(simulated here with a short delay)
For n = 1 To 100000
DoEvents 'yield as required
Next
Else 'run the ON code
.Width = .Width + nInc
.Height = .Height + nInc
.Caption = "Turn OFF"
.Left = .Left - nInc / 2
.Top = .Top - nInc / 2
.BackColor = RGB(255, 217, 183)
.ForeColor = RGB(0, 0, 0)
Me.Repaint 'redraw form
'add procedure here for the ON state
'(simulated here with a short delay)
For n = 1 To 100000
DoEvents 'yield as required
Next
End If
End With
End Sub
Private Sub CommandButton2_Click()
'Changes color and size-about-center
'of a typical CommandButton control,
'holds formats during process
'and restores all on exit.
Dim nInc As Integer, n As Long
'set size increase (say 0 to 10)
nInc = 8
'detect OFF state
With CommandButton2
If .Caption = "Turn ON" Then
.Width = .Width + nInc
.Height = .Height + nInc
.Caption = "Running"
.Left = .Left - nInc / 2
.Top = .Top - nInc / 2
.BackColor = RGB(255, 217, 183)
.ForeColor = RGB(0, 0, 0)
End If
End With
Me.Repaint 'redraw form
'add procedure here for the ON state
'(simulated here with a short delay)
For n = 1 To 100000
DoEvents 'yield as required
Next
'restore button just before exit
With CommandButton2
If .Caption = "Running" Then
.Width = .Width - nInc
.Height = .Height - nInc
.Caption = "Turn ON"
.Left = .Left + nInc / 2
.Top = .Top + nInc / 2
.BackColor = RGB(255, 205, 183)
.ForeColor = RGB(0, 0, 0)
End If
End With
Me.Repaint 'redraw form
End Sub
See Also
Styling User Forms
Summary
- FormatForm() is used to format a single specified userform with pre-selected colorings and fonts. This replaces a previous procedure to format all open userforms. Assumes that a userform called UserForm1 exists.
- The procedure AutoFormat() performs auto-sizing and layout for simple array data, so that the display and label bar is tabular in appearance, regardless of the length of the various data. This latter procedure also has facilities to transpose the input in case it is needed.
Code Modules
Last Modified 10 Jun 2017
Corrected name of TransposeArr2D() in Autoformat(). (12 Jul 2019)
Replaced multi-form procedure with single-form procedure FormatForm().(18 Jan 19)
Changed code to more general TypeName in FormatAllLoadedUserForms(28 June 18)
Added transpose function, previously omitted (10 Jun 2017)
Removed font procedures to their new page
Reduced number of AutoFormat() controls.(17 Nov 2016)
Added GetTextPoints(). (17 Nov 2016)
For Typical ThisWorkbook Module
Private Sub Workbook_Open()
'Shows typical use of form format function
'runs at workbook opening
'Assumes that a user form called UserForm1 exists
'load the form
Load UserForm1
'format the form
FormatForm UserForm1
'show the form
UserForm1.Show
'do other stuff then...
'repaint the form
UserForm1.Repaint
End Sub
For the Standard Module
Function FormatForm(vForm As Variant) As Boolean
'applies color and text formats
'to parameter user form object and its controls
'Be sure to repaint the user form after this function
Dim oCont As msforms.Control
Dim nColForm As Single, nColButtons As Single
Dim nColBox As Single, nColLabels As Single
Dim nColGenFore As Single, nColBoxText As Single
'set the color scheme here - add as required - eg:
nColForm = RGB(31, 35, 44) 'main form background
nColButtons = RGB(0, 128, 128) 'all button backgrounds
nColGenFore = RGB(255, 255, 255) 'all button text
nColBox = RGB(0, 100, 0) 'all text box backgrounds
nColBoxText = RGB(255, 255, 190) 'all text box text
nColLabels = RGB(23, 146, 126) 'all label text
'current user form name
'MsgBox vForm.Name
'apply user form formats here
vForm.BackColor = nColForm
'apply individual control formats
For Each oCont In vForm.Controls
'MsgBox oCont.Name
With oCont
Select Case TypeName(oCont)
Case "TextBox"
.BackColor = nColBox
.ForeColor = nColBoxText
.Font.Name = "Tahoma"
.Font.Size = 8
Case "ListBox"
.BackColor = nColBox
.ForeColor = nColBoxText
.Font.Name = "Tahoma"
.Font.Size = 8
Case "ComboBox"
.BackColor = nColBox
.ForeColor = nColBoxText
.Font.Name = "Tahoma"
.Font.Size = 8
Case "Frame"
.BackColor = nColForm
.ForeColor = nColGenFore
.Font.Name = "Tahoma"
.Font.Size = 8
Case "CommandButton", "ToggleButton"
.BackColor = nColButtons
.ForeColor = nColGenFore
.Font.Name = "Tahoma"
.Font.Size = 8
Case "SpinButton"
.BackColor = nColButtons
.ForeColor = nColGenFore
Case "OptionButton"
.BackStyle = fmBackStyleTransparent
.ForeColor = nColGenFore
.Font.Name = "Tahoma"
.Font.Size = 8
Case "CheckBox"
.BackStyle = fmBackStyleTransparent
.ForeColor = nColGenFore
.Font.Name = "Tahoma"
.Font.Size = 8
Case "Label"
.BackStyle = fmBackStyleTransparent
.ForeColor = nColLabels
.Font.Name = "Tahoma"
.Font.Size = 8
End Select
End With
Next oCont
FormatForm = True
End Function
Sub AutoFormat(vA As Variant, Optional bTranspose As Boolean = False)
' Takes array vA of say, 4 columns of data and
' displays on textbox in tabular layout.
' Needs a userform called ViewVars and a textbox
' called Textbox1. Code will adjust layout.
' Transpose2DArr used only to return data to (r, c) format.
Dim vB As Variant, vL As Variant, vR As Variant
Dim r As Long, c As Long, m As Long, sS As String
Dim nNumPadSp As Long, TxtLab As Control, MaxFormWidth As Long
Dim sAccum As String, sRowAccum As String, bBold As Boolean
Dim nLineLen As Long, BoxFontSize As Long, BoxFontName As String
Dim sLabAccum As String, nLabPadSp As Long, oUserForm As Object
Dim Backshade As Long, BoxShade As Long, BoxTextShade As Long
Dim ButtonShade As Long, ButtonTextShade As Long
Dim Lb1 As Long, Ub1 As Long, Lb2 As Long, Ub2 As Long
Dim TextLength As Long, bItalic As Boolean
' decide to transpose input or not
If bTranspose = True Then
TransposeArr2D vA, vR
vA = vR
End If
' get bounds of display array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vL(Lb2 To Ub2) ' make labels array
ReDim vB(Lb2 To Ub2) ' dimension column width array
'--------------------------------------------------------------
' SET USER OPTIONS HERE
'--------------------------------------------------------------
' set the name of the userform made at design time
Set oUserForm = ViewVars
' set limit for form width warning
MaxFormWidth = 800
' make column labels for userform - set empty if not needed
vL = Array("Variable", "Procedure", "Module", "Project")
' colors
Backshade = RGB(31, 35, 44) 'almost black - used
ButtonShade = RGB(0, 128, 128) 'blue-green - not used
BoxShade = RGB(0, 100, 0) 'middle green - used
ButtonTextShade = RGB(230, 230, 230) 'near white - not used
BoxTextShade = RGB(255, 255, 255) 'white - used
' Font details are to be found below
'--------------------------------------------------------------
' find maximum width of array columns
' taking account of label length also
For c = Lb2 To Ub2
m = Len(vL(c)) 'label
For r = Lb1 To Ub1
sS = vA(r, c) 'value
If Len(sS) >= m Then
m = Len(sS)
End If
Next r
'exits with col max array
vB(c) = m
m = 0
Next c
' For testing only
' shows max value of each column
' For c = LB2 To UB2
' MsgBox vB(c)
' Next c
For r = Lb1 To Ub1
For c = Lb2 To Ub2
If c >= Lb2 And c < Ub2 Then
' get padding for current element
nNumPadSp = vB(c) + 2 - Len(vA(r, c))
Else
' get padding for last element
nNumPadSp = vB(c) - Len(vA(r, c))
End If
' accumulate line with element padding
sAccum = sAccum & vA(r, c) & Space(nNumPadSp)
' get typical line length
If r = Lb1 Then
sRowAccum = sRowAccum & vA(Lb1, c) & Space(nNumPadSp)
nLineLen = Len(sRowAccum)
End If
Next c
' accumulate line strings
sAccum = sAccum & vbNewLine
Next r
' accumulate label string
For c = Lb2 To Ub2
If c >= Lb2 And c < Ub2 Then
' get padding for current label
nLabPadSp = vB(c) + 2 - Len(vL(c))
Else
' get padding for last element
nLabPadSp = vB(c) - Len(vL(c))
End If
' accumulate the label line
sLabAccum = sLabAccum & vL(c) & Space(nLabPadSp)
Next c
' load user form
Load oUserForm
'================================================================
' SET FONT DETAILS HERE. THESE AFFECT ALL AUTOSIZING.
'================================================================
BoxFontSize = 12 'say between 6 to 20 points
bBold = True 'True for bold, False for regular
bItalic = False 'True for italics, False for regular
BoxFontName = "Courier" 'or other monospaced fonts eg; Consolas
'================================================================
' make the labels textbox
Set TxtLab = oUserForm.Controls.Add("Forms.TextBox.1", "TxtLab")
' format the labels textbox
With TxtLab
.WordWrap = False
.AutoSize = True 'extends to fit text
.Value = ""
.font.Name = BoxFontName
.font.SIZE = BoxFontSize
.font.Bold = bBold
.font.Italic = bItalic
.ForeColor = BoxTextShade
.Height = 20
.Left = 20
.Top = 15
.Width = 0
.BackStyle = 0
.BorderStyle = 0
.SpecialEffect = 0
End With
'apply string to test label to get length
TxtLab.Value = sLabAccum & Space(2)
TextLength = TxtLab.Width
'MsgBox TextLength
'format userform
With oUserForm
.BackColor = Backshade
.Width = TextLength + 40
.Height = 340
.Caption = "Redundant variables list..."
End With
' check user form is within max width
If oUserForm.Width > MaxFormWidth Then
MsgBox "Form width is excessive"
Unload oUserForm
Exit Sub
End If
'format the data textbox
With oUserForm.TextBox1
.ScrollBars = 3
.WordWrap = True
.MultiLine = True
.EnterFieldBehavior = 1
.BackColor = BoxShade
.font.Name = BoxFontName
.font.SIZE = BoxFontSize
.font.Bold = bBold
.font.Italic = bItalic
.ForeColor = BoxTextShade
.Height = 250
.Left = 20
.Top = 40
.Width = TextLength
.Value = sAccum
End With
'show the user form
oUserForm.Show
End Sub
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
Check if a Workbook has VBA code
Summary
This VBA code module is made for Excel, but is easily adapted for other MS Office applications. It checks a workbook to see if it contains any useful VBA dimensional or structural code. Line counting has been found to be less reliable than this since even empty modules will show two lines of code each.
The Code Module
- Place all of the code below into the same standard module, and identify the test workbook address in wb.
- Then, run the procedure CheckForVBA to check whether or not the test workbook contains identifiable VBA code structures.
- The procedures first check to see that the workbook is not locked.
- Users can modify the test keyword list in procedure ContainsVBAKeyWords.
- The test workbook is closed again after inspection.
- Results are shown in message boxes here, but the top section is easily modified for other uses.
Option Explicit
Sub CheckForVBA()
'Run this procedure to know whether a specified workbook has VBA code
'Assumes that workbook to test is in same folder and called Book2.xlsm
'Set reference to Microsoft VBA Extensibility 5.5
Dim wb As Workbook, nL As Long, bR As Boolean
'set full address of workbook to test here
'if just file name then same folder is assumed
Set wb = Workbooks.Open("Book2.xlsm")
'check for code if project is not locked
If IsProtectedVBProject(wb) = False Then
'check for vba code
If WbkHasVBA(wb) = True Then
MsgBox "Workbook " & wb.FullName & vbCrLf & _
"CONTAINS VBA code structure."
Else
MsgBox "Workbook " & wb.FullName & vbCrLf & _
"DOES NOT contain VBA code structure."
End If
Else
MsgBox "The VBA Project is LOCKED;" & vbCrLf & _
"might have VBA but unable to confirm."
End If
'close the test workbook
wb.Close
End Sub
Function IsProtectedVBProject(ByVal wb As Workbook) As Boolean
'returns TRUE if VBA is password protected, else false
Dim nComp As Integer
nComp = -1
On Error Resume Next
nComp = wb.VBProject.VBComponents.Count
On Error GoTo 0
If nComp = -1 Then
IsProtectedVBProject = True
Else
IsProtectedVBProject = False
End If
End Function
Private Function WbkHasVBA(ByVal wb As Workbook) As Boolean
'returns true if workbook contains VBA, else false.
'Code must not be locked.
'Set reference to Microsoft VBA Extensibility 5.5
Dim VBComp As VBIDE.VBComponent
Dim VBMod As VBIDE.CodeModule
Dim nLines As Long, sMod As String
'get each module one at a time
For Each VBComp In wb.VBProject.VBComponents
Set VBMod = VBComp.CodeModule
nLines = VBMod.CountOfLines
If nLines <> 0 Then
sMod = VBMod.Lines(1, nLines)
'check for significant code entries
If ContainsVBAKeyWords(sMod) Then
WbkHasVBA = True
Exit For
End If
End If
Next VBComp
Set VBComp = Nothing
Set VBMod = Nothing
End Function
Function ContainsVBAKeyWords(ByVal sModule As String) As Boolean
'Returns true if input string contains any listed word,
'else false. User should add keywords of interest to vKeyList
Dim vKeyList As Variant, nC As Integer, bM As Boolean
'set the key list of interest here
vKeyList = Array("End", "Dim", "Public", "Private", "Friend", "Property", _
"Type", "Declare", "Sub", "Function")
'loop through keylist and compare with parameter module string
For nC = LBound(vKeyList) To UBound(vKeyList)
bM = sModule Like "*" & vKeyList(nC) & "*"
If bM = True Then
ContainsVBAKeyWords = True
Exit For
End If
Next nC
End Function
Get the VBA Code String
Summary
The VBA Editor
Getting the Whole Project String
The code module below is written for Excel but is easily adapted for Word and other MS Office applications. It makes a single string out of the entire code project for the same workbook in which it is run. In the past it has been found useful when a long string is needed to test say, character frequency code. With only slight modification the individual module text can be returned, and other details.
Sub TestGetVBAProjString()
'run this
'assumes VBA code is not locked
Dim sStr As String, nComps As Integer
Dim vA As Variant, nTLines As Long
'get whole string
sStr = GetVBAProjString
'show start of project string
MsgBox sStr
End Sub
Function GetVBAProjString() As String
'gets ThisWorkbook's whole VBA project string
'Set reference to Microsoft VBA Extensibility 5.5
Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
Dim VBMod As VBIDE.CodeModule, sMod As String, sProj As String
Dim nLines As Long
'get ref to ThisWorkbook project
Set VBProj = ThisWorkbook.VBProject
'loop through VBComponents collection
For Each VBComp In VBProj.VBComponents
Set VBMod = VBComp.CodeModule
nLines = VBMod.CountOfLines
If nLines <> 0 Then
sMod = VBMod.Lines(1, nLines)
sProj = sProj & vbCrLf & _
UCase(Chr(39) & VBComp.Name) & _
vbCrLf & vbCrLf & sMod
Else 'just accum name of empty component
sProj = sProj & vbCrLf & _
UCase(Chr(39) & VBComp.Name) & _
vbCrLf & vbCrLf
End If
Next VBComp
GetVBAProjString = sProj
Set VBProj = Nothing: Set VBComp = Nothing
Set VBMod = Nothing
End Function
External Links
- Programming in the VBA Editor : A comprehensive page by Pearson for the VBA editor.
VBA Code Indenter
Summary
- This admittedly long code module is used to indent or format any VBA code that it finds on the clipboard.. It uses fairly standard code indenting rules, examples of which can be seen in the formatting of the code on this page. Commercial formatting utilities are now available for VBA editors in 64-bit Windows, but the code below runs, not as an add-in but as a simple VBA code module. Within reason it will work for all recent versions of Windows and Excel, and with other Microsoft Office applications that can run VBA. It is fast enough for even the most critical user.
- It places the indented text back on the clipboard to replace the original text. The user can then paste it as he pleases.
- The first effort has few options.
- The depth of indenting can be set. This is done by setting the number of spaces per tab.
- The number of consecutive blank lines can be set. This is limited to none, one, or left as they are found.
- Existing line numbers can be preserved or removed, though no renumbering facility has been provided.
- Shared label lines can be split onto their own lines.
- The code routinely replaces comments that are continuations with comments on their own lines, though users can elect to avoid changes to comments altogether. If comment changes are permitted:
- Rem comment style is optionally replaced with the apostrophe style.
- Users can choose to insert one space after the comment apostrophe or to remove it where it already exists.
VBA Code Indenter-Formatter Module
A few points bear mention:
- The code runs as one complete standard module. Run the procedure Indenter() to indent the clipboard content.
- The user might also consider an optional user form to preview the indented output string (sRet in procedure Indenter) prior to Paste.
- Select code with complete pairings to make best use of the indenter. For example, so that there are no obvious If's without End If's. That said, snippets of code, procedures, or whole modules can be indented. In fact any text with recognized VBA keywords and line breaks, will get indented. Users should set the VBA editor error settings to Break for Unhandled Errors to avoid unnecessary interruptions from the intentional raising of errors.
- Readers who find the matter interesting might consider adding any bug reports to Discussion, and I will look at them when I can.
Work Method Used
All working is done in a module-level string array. The process is:
- Get the clipboard string first. The method used to get the string is the same as the one listed elsewhere in this series. See Clipboard VBA, for the DataObject clipboard methods. This method replaces an earlier method using a dummy user form.
- Load an array with the string as a set of lines. Load only the code part without any line number that may be present. Then remove the existing indentation from every line. This means any leading and lagging spaces and tabs.
- Re-connect lines broken with continuation marks. This process avoids many line identification problems, especially from follow-on comment lines that have been folded without their own continuation marks.
- Identify and mark the array with line types. The line types that come in closed structures, like For...Next or Sub...End Sub pairs, are especially important for indenting. These are marked as start and end line types respectively. Initially, it is not important which structures they are, just whether or not they are starts or ends. Middles such as Else also need to be identified, as well as comment, blank lines, and a large set of so-called other lines.
- Match up corresponding start and end lines. It works like this: Starting at the top of the code; select the first start line and count it as one, then move down, incrementing both start and end counters until the two counters are equal; the matched end line is then found. After resetting the counters, move down to the second start, and repeat the process until all of the start lines have been matched. The array start lines are marked with the row numbers for the corresponding end matches.
- Check the pair counts. If the code does not contain at least one start-end structure, or the start and end totals do not match, the user is invited to proceed or exit. A user assigned error is raised to achieve exit.
- Assign the indents and outdent counts for the main structures. Starting at the top of the code lines, go to the first line marked as a start. Add one indent count for all of the lines that lie between that start and its corresponding end line. Move down to the next start line and repeat the process until it is done. Now, for any line anywhere in the array that is marked as a middle, outdent, that is, subtract one indent count. Indent counts are converted to spaces using an indenting option.
- Join indent spaces to the code lines and make one string from them all. Although users can set a spacing option, four spaces to each indent unit seems to be the most useful, much as in the VBA editor itself.
- Upload the indented string to the clipboard, then advise that it is there, ready for paste.
Code Module Modifications
15 Dec 2018: Code modified to add error when clipboard not text.
14 Dec 2018: Code modified to use DataObject copy and paste methods.
29 Mar 2017: Minor edit to GetClipboard function comment.
Option Explicit
Private sW() As String
Sub Indenter()
' ===============================================================================
' Run the sub "Indenter" to format any VBA code text that is on the clipboard.
' The indented version will be found on the clipboard, replacing the original.
' ===============================================================================
Dim sClip As String, msg As String
Dim vT As Variant, vU As Variant, vS As Variant, sRet As String
Dim bModifyComments As Boolean, bMC As Boolean, bOnlyAposComments As Boolean
Dim bOAC As Boolean, bApostropheSpaced As Boolean, bAS As Boolean
Dim bSplitLabelLines As Boolean, bSL As Boolean, bKeepLineNumbers As Boolean
Dim bKLN As Boolean, nSpacesPerIndentTab As Long, nSPIT As Long
Dim nMaxAdjacentBlankLines As Long, nMABL As Long
' ===============================================================================
' SET USER OPTIONS HERE
' ===============================================================================
nSpacesPerIndentTab = 4 ' Sets number of spaces per tab - depth of indenting,
' ' best settings found to be 2, 3, or 4.
'---------------------------------------------------------------------------------
nMaxAdjacentBlankLines = 7 ' Sets number of adjacent blank lines in output
' ' 0 for none, or 1. Set > 1 to leave as found.
'---------------------------------------------------------------------------------
bModifyComments = False ' True to allow other modifications to comments, and
' ' changing of continuation comment groups into own-line
' ' comments. False, for no changes to comments.
' 'set bModifyComments to true for these to have any effect;
bOnlyAposComments = True ' True to change any r e m style comments to
' ' to apostrophe style, else false to leave as found.
bApostropheSpaced = False ' True to place spaces after apostrophies in
' ' comments, else False to remove any single space.
'---------------------------------------------------------------------------------
bSplitLabelLines = False ' True to split label lines onto own lines if they
' ' are shared, else False to leave as they are found.
'---------------------------------------------------------------------------------
bKeepLineNumbers = True ' True to preserve existing line numbers, if any,
' ' else False to remove any numbers during indent.
'---------------------------------------------------------------------------------
'
' ================================================================================
nSPIT = nSpacesPerIndentTab: nMABL = nMaxAdjacentBlankLines
bMC = bModifyComments: bOAC = bOnlyAposComments: bAS = bApostropheSpaced
bSL = bSplitLabelLines: bKLN = bKeepLineNumbers
On Error GoTo Err_Handler
Erase sW() ' erase work array
' ---------------------------------------------------------------------------------
sClip = GetFromClip ' GETS CLIPBOARD STRING
ProjStrTo1DArr sClip, vS ' String of lines to 1D array of lines. Base zero.
ModifyComments vS, vT, bOAC, bAS, bMC ' Modifies comments; removes continuation
LabelLineSplit vT, vU, bSL ' 1D array to 1D array. Splits shared label lines.
ClpToArray vU ' 1D array to 2D module array. Separates line numbers.
JoinBrokenLines ' 2D array. Joins-up continuation lines.
GetLineTypes ' 2D array. Marks array with line types.
MatchPairs ' 2D array. Matches-up starts and ends.
CheckPairs ' 2D array. Crude checking by pair counts.
Indents ' 2D array. Adds tab counts for indents
Outdent ' 2D array. Subtracts tab count for outdents.
SpacePlusStr nSPIT, bKLN ' 2D array. Adds indent spaces to line strings.
MaxBlanks sRet, nMABL ' 2D array to STRING. Also limits blank lines.
CopyToClip sRet ' INDENTED STRING TO CLIPBOARD
MsgBox "The indented string is now on the clipboard."
' ---------------------------------------------------------------------------------
Exit Sub
Err_Handler:
If Err.Number <> 0 Then
Select Case Err.Number
Case 12345 ' raised in CheckPairs
' optional exit - user selected exit
' partial selection has mismatched structure bounds
' or only trivial text without structures at all
Err.Clear
Exit Sub
Case 12346 ' raised in JoinBrokenLines
' compulsory exit
' partial selection breaks a statement continuation group
Err.Clear
Exit Sub
Case 12347 ' raised in ModifyComments
' compulsory exit
' partial selection breaks a comment continuation group
Err.Clear
Exit Sub
Case -2147221404 'clipboard data object not text
MsgBox "Clipboard does not contain text - closing"
Err.Clear
Exit Sub
Case Else
' all other errors
msg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
Err.Clear
MsgBox msg, vbCritical, "Error"
Exit Sub
End Select
End If
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.
'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.
'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
Sub ProjStrTo1DArr(sIn As String, vR As Variant)
' Input is a string of code lines that are newline separated
' Output is a 1D array containing the set of lines
'vR IS ZERO BASED
Dim LB As Long, UB As Long
' split clipboard string into lines
If sIn <> "" Then
vR = Split(sIn, vbNewLine)
LB = LBound(vR): UB = UBound(vR)
Else
Exit Sub
End If
End Sub
Sub ModifyComments(vA As Variant, vR As Variant, _
Optional bOnlyAposComments As Boolean = True, _
Optional bApostropheSpaced As Boolean = True, _
Optional bEnable As Boolean = True)
'Input 1D array vA; Output 1D array vR
'Changes all comment continuation groups into
'stand-alone comments, and modifies comments.
'Comments are modified in ApostropheSpaces().
'When bDisable is true, the input array is returned intact
'vR IS BASE ZERO
Dim vB As Variant, bHasMarker As Boolean
Dim m As Long, n As Long, LB1 As Long, UB1 As Long
Dim sL As String, sFP As String, sT As String
Dim sCom1 As String, sCom As String, sComR As String
Dim sR1 As String, sR2 As String, sR4 As String, sR5 As String
Dim bOAC As Boolean, bAS As Boolean
bOAC = bOnlyAposComments
bAS = bApostropheSpaced
'use a work array
LB1 = LBound(vA): UB1 = UBound(vA)
'enable or disable proc
If bEnable = False Then
ReDim vR(LB1 To UB1)
vR = vA
Exit Sub
Else
ReDim vB(LB1 To UB1)
vB = vA
End If
'misc string definitions
sR1 = Chr(82) & Chr(101) & Chr(109) & Chr(32) 'R e m + spc
sR2 = Chr(82) & Chr(101) & Chr(109) & Chr(58) 'R e m + colon
sR4 = Chr(39) 'apost
sR5 = Chr(39) & Chr(32) 'apost + spc
'LOOP THROUGH CODE LINES
For n = LB1 To UB1
m = n ' use internal loop counter
sL = vB(m) ' get line string
If sL = "" Then GoTo NextArrayLine
' test whether line string qualifies at all
SplitStrAndComment sL, sFP, sCom
' FIND IF LINE HAS COMMENT
If sCom <> "" Then 'line contains a comment
' FIND FIRST LINE OF CONTINUATION GROUP
If Right$(sL, 2) = " _" Then 'found first of group
' remove comment's continuation markings
sCom1 = Left$(sCom, Len(sCom) - 2)
' do the modifications
ApostropheSpaces sCom1, sComR, bOAC, bAS
vB(m) = sFP & sComR ' update with remake
m = m + 1 'increment group counter
' catch exception for incomplete group
If m > UB1 Then
MsgBox "Broken continuation group detected." & vbCrLf & _
"Please make a more complete selection."
Err.Raise 12347
Exit Sub
Else
' do other parts of continuation group
GoTo DoRestOfGroup
End If
Else
' HAS COMMENT BUT NO CONTINUATION
sCom1 = sCom
' do the modifications
ApostropheSpaces sCom1, sComR, bOAC, bAS
vB(m) = sFP & sComR ' update with remake
' go to next array line
GoTo NextArrayLine
End If
Else
' HAS NO COMMENT AT ALL
GoTo NextArrayLine
End If
DoRestOfGroup:
'PROCESS SECOND GROUP LINE UP TO LAST
Do Until m > UB1
sL = Trim(vB(m)) ' get line string
bHasMarker = sL Like sR1 & "*" Or sL Like sR2 & "*" _
Or sL Like sR4 & "*" Or sL Like sR5 & "*"
If bHasMarker = False Then
sL = sR5 & sL ' add comment mark
End If
' modify and exit for line group last
If Right$(sL, 2) <> " _" Then
ApostropheSpaces sL, sComR, bOAC, bAS ' modify comment
vB(m) = sComR ' update array
n = m - 1 ' update loop counter
Exit Do 'group ending complete
End If
' modify and go to next if not group last
sL = Left$(sL, Len(sL) - 2) 'remove cont mark
ApostropheSpaces sL, sComR, bOAC, bAS ' modify comment
vB(m) = sComR ' update array
m = m + 1 'increment group counter
If m > UB1 Then
MsgBox "Broken continuation group detected." & vbCrLf & _
"Please make a more complete selection."
Err.Raise 12347
Exit Sub
End If
Loop
' go to next array line
GoTo NextArrayLine
NextArrayLine:
' resets
bHasMarker = False
sCom = "": sCom1 = "": sComR = ""
m = 0: sL = "": sFP = "": sT = ""
Next n
Transfers:
ReDim vR(LB1 To UB1)
vR = vB
End Sub
Function ApostropheSpaces(sIn As String, sOut As String, _
Optional bOnlyAposComments As Boolean = True, _
Optional bApostropheSpaced As Boolean = False) As Boolean
' Comment string in, modified comment string out
' These always start with one of two comment marker styles;
' r e m style or apostrophe style. Each has variations.
' At present, sIn broken line parts arrive apostrophied.
' ASCI values of work characters
' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
' R: chr(82),e: chr(101),m: chr(109),colon: chr(58)
Dim sR3 As String, sL As String, bModComments As Boolean
Dim sR1 As String, sR2 As String, sR4 As String, sR5 As String, bHasMarker As Boolean
' String definitions
sR1 = Chr(82) & Chr(101) & Chr(109) & Chr(32) 'R e m + spc
sR2 = Chr(82) & Chr(101) & Chr(109) & Chr(58) 'R e m + colon
sR4 = Chr(39) 'apost
sR5 = Chr(39) & Chr(32) 'apost + spc
bModComments = True ' true to apply local changes, else false to return sIn.
If bModComments = False Then
sOut = sL
Exit Function
End If
'get line string
sL = sIn
' Find if line fits any comment pattern
bHasMarker = sL Like sR1 & "*" Or sL Like sR2 & "*" _
Or sL Like sR4 & "*" Or sL Like sR5 & "*"
If bHasMarker = True Then
' REPLACE REM STYLE WITH APOSTROPHE
If bOnlyAposComments = True Then
' take first four charas of comment...
sR3 = Left$(sL, 4)
'if they fit r e m pattern...
If sR3 = sR1 Or sR3 = sR2 Then
'change the first four to an apostrophe
sR3 = Replace(sL, sR3, sR4, 1, 1)
sL = sR3
sR3 = ""
End If
End If
' SET SPACE BEFORE APOSTROPHE
If bApostropheSpaced = True Then
' take first two charas of comment...
sR3 = Left$(sL, 2)
'if they fit apostrophe pattern...
If sR3 <> sR5 Then
'change the first two to an apostrophe
sR3 = Replace(sL, sR4, sR5, 1, 1)
sL = sR3
sR3 = ""
End If
Else
' bApostropheSpaced is false so remove short space.
' provided that no more than one existing space,
' replace first instance of apos + spc with just apos.
If Left$(sL, 3) <> sR5 & Chr(32) And Left$(sL, 2) = sR5 Then
sR3 = Replace(sL, sR5, sR4, 1, 1)
sL = sR3
sR3 = ""
End If
End If
Else
MsgBox "Pattern failure in ApostropheSpaces"
Exit Function
End If
sOut = sL
ApostropheSpaces = True
End Function
Function LabelLineSplit(vA As Variant, vR As Variant, Optional bEnable As Boolean = True) As Boolean
'Input vA, 1D array with block of code lines.
'Output vR, 1D array with label lines split.
'Increases line count when if splitting is done
'Takes account of line continuations in decision making.
'When bDisable is true, the input array is returned intact
'vR IS BASE ZERO
Dim n As Long, sRC As String, vC As Variant
Dim sLN As String, sLL As String
Dim sL As String, sS As String, bPrevIsBroken As Boolean
Dim LBvA As Long, UBvA As Long, UB As Long
LBvA = LBound(vA): UBvA = UBound(vA)
'enable or disable proc
If bEnable = False Then
ReDim vR(LBvA To UBvA)
vR = vA
Exit Function
Else
ReDim vR(LBvA To 0)
End If
sRC = Chr(82) & Chr(101) & Chr(109) 'r e m
'Conditional transfer of lines
For n = LBvA To UBvA
'get full line string
sL = Trim(vA(n))
'exclusions
'tranfer intact if line blank or
'either kind of comment
If sL = "" Or Left$(sL, 1) = Chr(39) Or _
Left$(sL, 3) = sRC Then
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sL)
GoTo SkipThisOne
End If
' find if it has a label
If n = LBvA Then
' for first line only
' assume worth splitting
SplitLineParts sL, sLN, sLL, sS
Else ' for all lines after first
' test to see if prev line continued
bPrevIsBroken = Trim(vA(n - 1)) Like "* _"
If Not bPrevIsBroken Then 'test for label
SplitLineParts sL, sLN, sLL, sS
Else
' CONTINUATION SO TRANSFER IT INTACT
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sL)
GoTo SkipThisOne
End If
End If
' LABEL ACTION
If sLL <> "" Then
If Trim(sS) <> "" Then
' THERE IS A SHARED LABEL LINE TO SPLIT
ReDim Preserve vR(0 To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sLL) ' label onto line
ReDim Preserve vR(0 To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sS)
Else ' ALREADY ON ITS OWN LINE
' so transfer label to array
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sLL)
End If
Else ' NOT A LABEL AT ALL SO TRANSFER IT INTACT
ReDim Preserve vR(LBound(vR) To UBound(vR) + 1)
UB = UBound(vR)
vR(UB) = Trim(sL)
End If
SkipThisOne:
sL = "": sLN = "": sLL = "": sS = ""
Next n
Transfers:
ReDim vC(0 To UB - 1)
For n = LBound(vC) To UBound(vC)
vC(n) = vR(n + 1)
Next n
'exit as zero based array
ReDim vR(LBound(vC) To UBound(vC))
vR = vC
End Function
Function SplitStrAndComment(sIn As String, sFirstPart As String, sComment As String) As Boolean
'==============================================================================================
' Returns input-less-comment in sFirstPart and any comment string in sComment.
' Input sIn supplies one VBA code line string, and the two parts are returned untrimmed.
' Has good immunity to suffering and causing corruption from comment and quote text.
' For no comment found, sFirstPart is sIn, and sComment is empty.
' Method: Makes two runs; one search for apostrophe comments, and next for r e m comments;
' Removes any double quote pairs until relevant comment mark is located before any double quote.
' If any results are found, the one without search error has the comment that is longest.
' String stripped of quotes and position of comment mark are available but not returned here.
'==============================================================================================
Dim nPos As Long, sNoQuotes As String, sCmMrk As String
Dim nPos1 As Long, nPos2 As Long, sNoQuotes1 As String
Dim str1 As String, Str2 As String, m As Long
Dim vM As Variant, nLA As Long, nLR As Long, sNoQuotes2 As String
Dim q1 As Long, q2 As Long, a As Long, s1 As String, s2 As String
Dim bQuote As Boolean, bComment As Boolean, sA As String
Dim bACFound As Boolean, bRCFound As Boolean
' ASCI values of work characters
' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
' R: chr(82),e: chr(101),m: chr(109),colon: chr(58)
'two runs; first for apos, then r e m comments
vM = Array(Chr(39), Chr(82) & Chr(101) & Chr(109))
str1 = sIn
'run loop for each of two searches
For m = 1 To 2
'select one of two comment marks to search for
sCmMrk = vM(m - 1) 'zero based
' check the line string patterns
' asterisk; chr(42), apostrophe; chr(39), double-quote; chr(34)
bComment = str1 Like Chr(42) & sCmMrk & Chr(42) ' for an apostrophe
bQuote = str1 Like Chr(42) & Chr(34) & Chr(42) ' for a double quote
If bComment = True And bQuote = True Then
'has comment mark and has double quote
' set initial value
q2 = 1
Do
' get postion of first comment mark
a = InStr(q2, str1 & sCmMrk, sCmMrk)
' get postion of first double quote
q1 = InStr(q2, str1 & Chr(34), Chr(34))
If a <= q1 Then
'found comment
sA = Right$(str1, Len(str1) - a + 1)
nPos = a
sNoQuotes = str1
GoTo Output
ElseIf a > q1 Then
'find next quote
q2 = InStr(q1 + 1, str1 & Chr(34), Chr(34))
'if next quote is found
If q2 <> 0 Then
'remove charas from q1 to q2 inclusive
Str2 = Left$(str1, q1 - 1) & Right$(str1, Len(str1) - q2)
'set new start position for search
q2 = q2 + 1
End If
End If
Loop Until (a = q1)
ElseIf bComment = True And bQuote = False Then
' has comment mark but has no double quote
' so return original str and comment details
str1 = str1
a = InStr(1, str1 & sCmMrk, sCmMrk) ' position of first comment mark
sA = Right$(str1, Len(str1) - a + 1) ' comment string
nPos = a ' return position of comment
sNoQuotes = str1 ' return string without quotes
GoTo Output
Else
' no comment mark but has double quote, or
' no comment mark and no double quote.
' so return original string
sA = ""
nPos = 0
sNoQuotes = str1
GoTo Output
End If
Output:
'get details for each of two searches.
If m = 1 Then 'for apostrophe comment search
nLA = Len(sA) 'apos
s1 = sA
nPos1 = nPos
sNoQuotes1 = sNoQuotes
Else 'for r e m comment search
nLR = Len(sA) 'r e m
s2 = sA
nPos2 = nPos
sNoQuotes2 = sNoQuotes
End If
'select and return details for longest comment
If nLA > nLR Then
bACFound = True 'apos comment flag
nPos = nPos1 'position of comment
sNoQuotes = sNoQuotes1 'de-quoted original
sFirstPart = Left$(str1, nPos - 1) 'str before comment
sComment = s1 'comment string
ElseIf nLR > nLA Then
bRCFound = True 'r e m comment flag
nPos = nPos2 'de-quoted original 'position of comment
sNoQuotes = sNoQuotes2 'de-quoted original
sFirstPart = Left$(str1, nPos - 1) 'str before comment
sComment = s2 'comment string
Else
'no comments found
sFirstPart = str1 'str before comment
sComment = "" 'comment string
End If
Next m
SplitStrAndComment = True
End Function
Sub ClpToArray(vA As Variant)
' loads array with lines of clipboard
'vA IS 1D BASE ZERO ARRAY
'sW() IS 2D BASE ONE MODULE LEVEL ARRAY
Dim n As Long, m As Long, Num As Long
Dim sLN As String, sLS As String
Dim sLN1 As String, sLS1 As String
Dim LBvA As Long, UBvA As Long
Dim bPrevIsBroken As Boolean
Dim sL As String, sLP As String
'get bounds of vA
LBvA = LBound(vA): UBvA = UBound(vA)
' count lines in vA clipboard sample
Num = UBvA - LBvA + 1
' redim array
ReDim sW(1 To 12, 1 To Num)
' load lines
For n = LBvA To UBvA
sL = Trim(vA(n))
If n <> LBvA Then sLP = Trim(vA(n - 1))
' LINE NUMBER SPLIT DEPENDS ON CONTINUED LINES
' split line into line numbers and line strings
' find if it has a line number
If n = LBvA Then ' for first vA line only
' attempt split anyway
SplitLineNums sL, sLN1, sLS1
sLN = sLN1: sLS = sLS1
Else ' for all lines after first
' test to see if prev line continued
bPrevIsBroken = sLP Like "* _"
If Not bPrevIsBroken Then
' LOAD BOTH LINE NUMBER AND LINE STRING
SplitLineNums sL, sLN1, sLS1
sLN = sLN1: sLS = sLS1
Else
' CONTINUATION - LOAD LINE STRING ONLY
' any leading number is not a line number
sLN = "": sLS = sL
End If
End If
m = n + 1
' LOAD MODULE LEVEL STRING ARRAY sW()
sW(1, m) = m ' project line numbers
sW(2, m) = sLS ' trimmed line strings
sW(3, m) = "other" ' code line types
sW(4, m) = 0 ' structure end numbers
sW(5, m) = 0 ' record tab count
sW(6, m) = "" ' indented strings
sW(7, m) = "" ' continuations marking
sW(8, m) = "" ' continuation group strings
sW(9, m) = sLN ' user code line numbers
sW(10, m) = "" ' optional output renumbering
sW(11, m) = "" ' marked if "Proc" or "End Proc"
sW(12, m) = "" ' marked if "Label"
Next n
End Sub
Sub JoinBrokenLines()
' Identifies lines with continuation marks
' Joins these broken lines into one line
' Marks newly redundant lines as "other"
Dim vA As Variant, IsContinuation As Boolean
Dim str As String, saccum As String
Dim n As Long, s As Long, nS As Long, nE As Long
' mark all lines that have a continuation chara
For n = LBound(sW(), 2) To UBound(sW(), 2)
str = sW(2, n) ' line string
IsContinuation = str Like "* _"
If IsContinuation Then sW(7, n) = "continuation"
Next n
' mark the start and end of every continuation group
For n = LBound(sW(), 2) To (UBound(sW(), 2) - 1)
If n = 1 Then ' for the first line only
If sW(7, n) = "continuation" Then sW(8, n) = "SC"
If sW(7, n) = "continuation" And sW(7, n + 1) <> "continuation" _
Then sW(8, n + 1) = "EC"
Else ' for all lines after the first
' find ends
If sW(7, n) = "continuation" And sW(7, n + 1) <> "continuation" Then
sW(8, n + 1) = "EC"
End If
' find starts
If sW(7, n) = "continuation" And sW(7, n - 1) <> "continuation" Then
' If sW(7, n) <> "continuation" And sW(7, n + 1) = "continuation" Then
sW(8, n) = "SC"
End If
End If
Next n
' Count continuation group starts and ends
For n = LBound(sW(), 2) To UBound(sW(), 2)
If sW(8, n) = "SC" Then nS = nS + 1
If sW(8, n) = "EC" Then nE = nE + 1
Next n
If nS <> nE Then
' Error. Means there is an incomplete continuation selection
' Advise, raise error and exit
MsgBox "The selection made is not sufficiently complete." & vbCrLf & _
"A line that is continued has parts missing." & vbCrLf & _
"Please make a another selection."
Err.Raise 12346
Exit Sub
End If
' make single strings from each continuation group
For n = LBound(sW(), 2) To (UBound(sW(), 2) - 1)
If sW(8, n) = "SC" Then ' group starts
' join strings to make one string per continuation group
s = n
vA = Split(CStr(sW(2, n)), "_")
str = CStr(vA(0))
saccum = str
Do Until sW(8, s) = "EC"
s = s + 1
sW(3, s) = "other" ' mark all but first line in group as "other"
vA = Split(CStr(sW(2, s)), "_")
str = CStr(vA(0))
saccum = saccum & str
Loop
sW(8, n) = saccum ' place at first line level in array
End If
str = ""
saccum = ""
s = 0
Next n
End Sub
Sub GetLineTypes()
' Marks array with the indentable closed structures
Dim n As Long, m As Long, str As String
Dim bProc As Boolean
Dim Outdents, StructureStarts, StructureEnds, bEndProc As Boolean
Dim IsComment As Boolean, IsBlank As Boolean
Dim IsContinuation As Boolean, IsOK As Boolean
' THESE PATTERNS DECIDE HOW STRUCTURES ARE INDENTED - (revised Oct. 2016)
' ================================================================================
' STARTS LIST - starts of structures that contain lines to indent
StructureStarts = Array( _
"Do", "Do *", "Do: *", _
"For *", _
"If * Then", "If * Then: *", "If * Then [!A-Z,!a-z]*", _
"Select Case *", _
"Type *", "Private Type *", "Public Type *", _
"While *", _
"With *", _
"Sub *", "Static Sub *", "Private Sub *", "Public Sub *", "Friend Sub *", _
"Private Static Sub *", "Public Static Sub *", "Friend Static Sub *", _
"Function *", "Static Function *", "Private Function *", _
"Public Function *", "Friend Function *", "Private Static Function *", _
"Public Static Function *", "Friend Static Function, *", _
"Property Get *", "Static Property Get *", "Private Property Get *", _
"Public Property Get *", "Friend Property Get *", _
"Private Static Property Get *", "Public Static Property Get *", _
"Friend Static Property Get *", _
"Property Let *", "Static Property Let *", "Private Property Let *", _
"Public Property Let *", "Friend Property Let *", _
"Private Static Property Let *", "Public Static Property Let *", _
"Friend Static Property Let *", _
"Property Set *", "Static Property Set *", "Private Property Set *", _
"Public Property Set *", "Friend Property Set *", _
"Private Static Property Set *", "Public Static Property Set *", _
"Friend Static Property Set *")
' ENDS LIST - ends of structures that contain lines to indent
StructureEnds = Array( _
"Loop", "Loop *", "Loop: *", _
"Next", "Next *", "Next: *", _
"End If", "End If *", "End If: *", _
"End Select", "End Select *", "End Select: *", _
"End Type", "End Type *", "End Type: *", _
"Wend", "Wend *", "Wend: *", _
"End With", "End With *", "End With: *", _
"End Sub", "End Sub *", _
"End Function", "End Function *", _
"End Property", "End Property *", "End Property: *")
' OUTDENTS LIST - exceptions that need re-aligned with respective start elements
Outdents = Array( _
"Else", "Else *", "Else: *", "Else:", _
"ElseIf * Then", "ElseIf * Then*", _
"Case", "Case *", _
"Case Else", "Case Else:", "Case Else *", "Case Else:*")
' ================================================================================
' mark array with line types - step through each line
For n = LBound(sW(), 2) To UBound(sW(), 2)
str = sW(2, n)
' mark each line if a blank
' mark each line if a blank
If Len(str) = 0 Then ' note blanks
sW(3, n) = "blank"
IsBlank = True
GoTo RoundAgain: ' comment
End If
' mark each line if an own-line comment or first of folded comment parts
IsComment = str Like Chr(39) & " *" Or str Like "' *" ' note comment lines
If IsComment Then
sW(3, n) = "comment"
GoTo RoundAgain
End If
' mark each line if a start, end, or middle
' and also if a proc start or proc end
bProc = str Like "*Sub *" Or str Like "*Function *" Or str Like "*Property *"
bEndProc = str Like "End Sub*" Or str Like "End Function*" Or str Like "End Property*"
' mark each line if a start element
For m = LBound(StructureStarts) To UBound(StructureStarts)
If sW(7, n) = "continuation" And sW(8, n) <> "" Then
IsOK = sW(8, n) Like StructureStarts(m)
Else
IsOK = str Like StructureStarts(m)
End If
If IsOK Then
sW(3, n) = "start"
If bProc Then sW(11, n) = "Proc"
Exit For
End If
Next m
If IsOK Then GoTo RoundAgain
' mark each line if an end element
For m = LBound(StructureEnds) To UBound(StructureEnds)
If sW(7, n) = "continuation" And sW(8, n) <> "" Then
IsOK = sW(8, n) Like StructureEnds(m)
Else
IsOK = str Like StructureEnds(m)
End If
If IsOK Then
sW(3, n) = "end"
If bEndProc Then sW(11, n) = "End Proc"
Exit For
End If
Next m
If IsOK Then GoTo RoundAgain
' mark each line if a middle element
For m = LBound(Outdents) To UBound(Outdents)
If sW(7, n) = "continuation" And sW(8, n) <> "" Then
IsOK = sW(8, n) Like Outdents(m)
Else
IsOK = str Like Outdents(m)
End If
If IsOK Then
sW(3, n) = "middle"
Exit For
End If
Next m
If IsOK Then GoTo RoundAgain
RoundAgain:
' reset loop variables
IsBlank = False
IsComment = False
IsContinuation = False
IsOK = False
bProc = False
bEndProc = False
Next n
End Sub
Sub MatchPairs()
' matches up the structure starts with their ends
Dim n As Long, q As Long, LB As Long, UB As Long
Dim CountStarts As Long, CountEnds As Long
Dim IsPastEnd As Boolean, IsAPair As Boolean
LB = LBound(sW(), 2): UB = UBound(sW(), 2)
' find start lines
For n = LB To UB
If sW(3, n) = "start" Then
q = n ' pass it to q for the loop
Do
If sW(3, q) = "start" Then
CountStarts = CountStarts + 1
ElseIf sW(3, q) = "end" Then
CountEnds = CountEnds + 1
End If
' exit condition is a pair found
If CountStarts = CountEnds Then ' this is match-found point
IsAPair = True
Exit Do
Else:
IsAPair = False
End If
' increment counter while accumulating
q = q + 1
' avoid access beyond upper limit of array
If q > UB Then
IsPastEnd = True
Exit Do
End If
Loop
' evaluate the loop exit causes
If IsAPair And IsPastEnd Then
' suggests that there is an unpaired structure
MsgBox "Unpaired structure for some element: " & n
ElseIf IsAPair And Not IsPastEnd Then
' found a matching structure closer for line at n
sW(4, n) = q
End If
End If
' reset loop variables
CountStarts = 0
CountEnds = 0
IsAPair = False
IsPastEnd = False
Next n
End Sub
Sub CheckPairs()
' counts structure starts and ends
' advises if code trivial or unpaired
Dim n As Long, CountStarts As Long, CountEnds As Long
Dim str As String, LB As Long, UB As Long, sM1 As String
Dim sM2 As String, Reply As String
LB = LBound(sW(), 2): UB = UBound(sW(), 2)
sM2 = "Continue with indent?" & vbNewLine & _
"Select YES to continue, or NO to exit"
' count start and end markings
For n = 1 To UB
str = sW(3, n)
If str = "start" Then CountStarts = CountStarts + 1
If str = "end" Then CountEnds = CountEnds + 1
Next n
' check for unmatched pairs and trivial text
If CountStarts > 0 And CountEnds > 0 Then
' maybe worth indenting
If CountStarts <> CountEnds Then
' possible code layout error
sM1 = "Mismatched structure pairing." & vbCrLf & _
"This will produce some indent error."
GoTo Notify
Else ' worth indenting and paired
Exit Sub
End If
Else
sM1 = "Only trivial text found" & vbCrLf & _
"No structures were found to indent."
GoTo Notify
End If
Notify:
Reply = MsgBox(sM1 & vbNewLine & sM2, vbYesNo + vbQuestion)
Select Case Reply
Case vbYes
Exit Sub
Case Else
Err.Raise 12345 ' user error
Exit Sub
End Select
End Sub
Sub Indents()
' adds indents between starts and ends
Dim n As Long, m As Long, sStr As String
For n = 1 To UBound(sW(), 2)
' get the line string
' row 3 has start markings
' corresponding row 4 has structure end number
sStr = sW(3, n)
' if string is a start element
If sStr = "start" Then
' indent all between start and end
For m = (n + 1) To sW(4, n) - 1
' indent one tab
sW(5, m) = sW(5, m) + 1
Next m
End If
Next n
End Sub
Sub Outdent()
' outdent keywords in middle of structures
Dim n As Long, Ind As Long, UB As Long
UB = UBound(sW(), 2)
' outdent loop
For n = 1 To UB
Ind = sW(5, n)
' if marked for outdent...
If sW(3, n) = "middle" Then
Ind = Ind - 1
sW(5, n) = Ind
End If
Next n
End Sub
Sub SpacePlusStr(ByVal SpacesInTab As Integer, _
Optional bKeepLineNums As Boolean = True)
' adds together line numbers, padding spaces, and
' line strings to make the indented line
' For bKeepLineNums true, line numbers kept as found,
' else false for their removal.
Dim nSPT As Long, nASC As Long, nGSC As Long, nALNL As Long
Dim p As Long, nMin As Long, nMax As Long, nTab As Long
'===============================================================
' NOTES ABOUT SPACING FOR INDENTS AND LINE NUMBERS
'===============================================================
' IN GENERAL;
' The general space count nGSC, the number of spaces
' to apply for the indent, is the prescribed number
' of tabs times the spaces-per-tab integer.
' BUT WITH LINE NUMBERS;
' For nMax < nSPT , then nASC = nGSC - nALNL
' For nMax >= nSPT, nASC = nGSC - nSPT + 1 + nMax - nALNL
' where,
' nMax is max line number length in the display set
' nSPT is the number of spaces per tab
' nASC is the number of actual spaces required as an indent
' nGSC is the general space count as described above
' nALNL is the number of digits in the current line number
'================================================================
' get the min and max lengths of any line numbers
LineNumMinMax nMax, nMin 'get min and max line numbers
' assign parameter
nSPT = SpacesInTab
' Loop through main string array
For p = 1 To UBound(sW(), 2)
nALNL = Len(sW(9, p))
' work out the general indent to apply
nTab = sW(5, p)
nGSC = nSPT * nTab 'general spaces for indent
' work out actual indent, modified for line numbers
Select Case nGSC
Case Is > 0
'for lines intended for indent at all
Select Case nMax
Case 0
nASC = nGSC
Case Is < nSPT
nASC = nGSC - nALNL
Case Is >= nSPT
nASC = nGSC - nALNL + nMax - nSPT + 1
End Select
'for lines not intended for indent
Case Is <= 0
nASC = 0
End Select
If bKeepLineNums = True Then
' combine line number, padding, and line string
sW(6, p) = sW(9, p) & Space(nASC) & sW(2, p)
Else
'combine padding and line string
sW(6, p) = Space(nGSC) & sW(2, p)
End If
Next p
End Sub
Function LineNumMinMax(max As Long, min As Long) As Boolean
'gets the minimum value of user line numbers from array
Dim n As Long
For n = LBound(sW, 2) To UBound(sW, 2)
If Len(sW(9, n)) >= max Then
max = Len(sW(9, n))
End If
If Len(sW(9, n)) <= min Then
min = Len(sW(9, n))
End If
Next n
LineNumMinMax = True
End Function
Sub MaxBlanks(sRet As String, Optional nMaxNumBlankLines As Long = 555)
' makes a single string from all code lines, indented, ready for display.
' and makes a single string from the original code lines as found.
' nMaxNumBlankLines; restricts number of contiguous blank lines.
' Values other than 0 or 1 leave blanks as found. (Default).
Dim Str2 As String, n As Long, bOK As Boolean
' accumulate original lines as one string - not used here
' For p = 1 To UBound(sW(), 2)
' Str1 = Str1 & sW(2, p) & vbNewLine
' Next p
' accumulate indented lines as one string
For n = 1 To UBound(sW(), 2)
If n = 1 And TrimStr(CStr(sW(2, n))) = "" Then
' do not accum the line
Exit For
End If
' if any line string after the first is blank
If TrimStr(CStr(sW(2, n))) = "" Then
Select Case nMaxNumBlankLines
Case 0
' do not accumulate the line
bOK = False
Case 1
' accum if only one
If TrimStr(CStr(sW(2, n - 1))) = "" Then
bOK = False
Else
bOK = True
End If
Case Else
' accumulate anyway
bOK = True
End Select
Else
' if not blank - accumulate
bOK = True
End If
If bOK Then
' accumulate line strings
Str2 = Str2 & sW(6, n) & vbNewLine ' to display indent amounts
End If
bOK = False
Next n
sRet = Left(Str2, Len(Str2) - 2)
End Sub
Function TrimStr(ByVal str As String) As String
' trims leading and lagging spaces and tabs from strings
Dim n As Long
n = Len(str)
Do ' delete tabs and spaces from left of string
If Left(str, 1) = Chr(32) Or Left(str, 1) = Chr(9) Then
n = Len(str)
str = Right(str, n - 1)
Else
' left is done
Exit Do
End If
Loop
Do ' delete tabs and spaces from right of string
If Right(str, 1) = Chr(32) Or Right(str, 1) = Chr(9) Then
n = Len(str)
str = Left(str, n - 1)
Else
' left is done
Exit Do
End If
Loop
TrimStr = str
End Function
Function SplitLineNums(sIn As String, sLN As String, sLS As String) As Boolean
' takes sIn and returns line number and line string parts both trimmed
' returns an empty string for any missing part.
' assumes that previous line string is not continued - handle in call proc
Dim sL As String, sS As String
Dim n As Long, sA As String, nL As Long
Dim nLS As Long, nLN As Long, bOK As Boolean
sL = Trim(sIn)
nL = Len(sL)
' if first chara numeric...
If IsNumeric(Left$(sL, 1)) Then
' separate at change to alpha
For n = 1 To nL
sS = Mid$(sL, n, 1)
' if an integer or colon...
If Asc(sS) >= 48 And Asc(sS) <= 58 Then
' accumulate...
sA = sA & sS
Else
' change point found
bOK = True
Exit For
End If
Next n
' but for numbered blank lines...
If Len(sA) = nL Then bOK = True
End If
' if a line number was found...
If bOK Then
sLN = Trim(sA)
nLN = Len(sA)
sLS = Trim(Right$(sL, nL - nLN))
nLS = Len(sLS)
Else
' if no line number was found...
sLN = "": nLN = 0: sLS = sL: nLS = nL
End If
' MsgBox sLN: MsgBox nLN: MsgBox sLS: MsgBox nLS
SplitLineNums = True
End Function
Function SplitLineParts(sIn As String, sLN As String, _
sLL As String, sS As String) As Boolean
' sIn; input is one whole vba code line string
' sLN; returns line number if used, with colon if used
' sLL; returns label string if used, always with its colon
' sSS; returns split string parts if any, lead space intact
Dim nPos As Long
' check for line number and labels
If IsLineNumbered(sIn) = True Then
sS = StrLessLineNumber(sIn, sLN) ' line number
Else
If IsLabelled(sIn) = True Then
nPos = InStr(1, sIn, ":", vbTextCompare)
sS = Right$(sIn, Len(sIn) - nPos) ' string part
sLL = Left$(sIn, nPos) ' line label
Else
sS = sIn
End If
End If
SplitLineParts = True
End Function
Function IsLineNumbered(ByVal str As String) As Boolean
' assumes test done to exclude continuation from previous line
' Returns true if str starts with a vba line number format
' Line number range is 0 to 2147483647 with or without end colon
If str Like "#*" Then
IsLineNumbered = True
End If
End Function
Function StrLessLineNumber(ByVal str As String, sLineNumber As String) As String
' assumes that possibility of number being a continuation is excluded.
' Returns with string separated from line number
' Includes any leading space
' Returns whole string if not
Dim nPos As Long, sT As String
' default transfer
StrLessLineNumber = str
' line numbers range is 0 to 2147483647
' if the line is some kind of line number line at all...
If str Like "#*" Then
' specifically, if the line uses a colon separator...
If str Like "#*: *" Then
If InStr(str, ":") Then
' get colon position
nPos = InStr(1, str, ":", vbTextCompare)
GoTo Splits
End If
End If
' specifically, if the line uses a space separator
If str Like "#* *" Then
If InStr(str, " ") Then
nPos = InStr(1, str, " ", vbTextCompare) - 1
GoTo Splits
End If
' default, if there is only a line number with nothing after...
Else
' to return a line number but empty split string...
nPos = Len(str)
GoTo Splits
End If
Splits:
' return string after separator
StrLessLineNumber = Mid(str, 1 + nPos)
sT = StrLessLineNumber
sLineNumber = Left$(str, Len(str) - Len(sT))
End If
End Function
Function IsLabelled(ByVal str As String) As Boolean
' assumes that possibility of being any kind of
' comment or a line number are first excluded
' Returns true if str starts with a vba label format
Dim nPosColon As Long, nPosSpace As Long
Dim sRC As String
' define r e m + colon
sRC = Chr(82) & Chr(101) & Chr(109) & Chr(58)
' test for single colon exception and r e m colon exception
If str Like ":*" Or str Like sRC & "*" Then Exit Function
' test position of first colon
nPosColon = InStr(1, str & ":", ":")
' test position of first space
nPosSpace = InStr(1, str & " ", " ")
IsLabelled = nPosColon < nPosSpace
End Function
' INDENT NOTES
' =====================================================================================================
' *String Array sW() row details:
' *
' * Row 1: Integers: Clipboard code line numbers.
' * Row 2: Strings: Trimmed line strings.
' * Row 3: Strings: Line type markings; one of blank, comment, start, end, or middle.
' * Row 4: Integers: Line numbers for structure ends that match start markings.
' * Row 5: Integers: Records sum of number of indents that are due for that line.
' * Row 6: Strings: Line strings with their due indents added
' * Row 7: Strings: Line type markings; continuation
' * Row 8: Strings: Joined up continuation strings as single lines
' * Row 9: Strings: User code line numbers
' * Row 10: Strings: Renumbered line numbers
' * Row 11: Strings: Proc or End Proc markings for format exceptions
' * row 12: Strings: Marked "Label" for line label
' =====================================================================================================
' * Row 3 Markings:
' *
' * "other" The most usual thing; the kind found within structures, eg a = 3*b
' * "start" The start of a closed structure; eg, Sub, If, For, Select Case, etc.
' * "end" The end of a closed structure; eg, End Sub, End If, End select, etc.
' * "middle" The keywords that display level with starts; eg, Else, Case, etc.
' * "comment" The line is a comment line with its own apostrophe at its start
' * "blank" The line is completely blank
' *====================================================================================================
' * Row 7 Continuation Marks:
' *
' * Every line that ends with a continuation mark is identified as ' continuation' as well as the start
' * and end of each continuation grouping.
' *====================================================================================================
' * Row 8 Joined line strings:
' *
' * The start and end of each continuation grouping is marked. These are used to construct a full
' * length line from the several parts of each grouping. Only then is there line type identification.
' * To see the problem, a folded comment line with ' For' or ' Do' at the start of the second line would
' * otherwise be taken as a ' start' line. So too with some other line folds.
' * Joining allows better line typing
' *=====================================================================================================
See Also
External Links
Redundant Variables List
Summary
This very long code module lists an Excel project's redundant variables.
Running the top procedure checks the VBA project of ThisWorkbook, that is, the workbook in which the code is run. It produces both worksheet and user form outputs. The code is self-contained in the one module, but in addition, the user needs to make a user form called ViewVars, with a textbox in it called TextBox1. The details are not too important since the display is adjusted in code to fit the contents. However, the user form's property ShowModal should be set to False, and Multiline set to True. A testing mode of sorts can be had by setting boolean variable bUseWorkSheets in RunVarChecks to True. Be advised however, that this will clear all existing worksheets before writing to sheets one to five. To labor the point, if your intention is to not disturb the contents of project sheets one to five, then be sure that bUseWorkSheets of RunVarChecks is set to False; redundant variables will still be listed in the user form ViewVars after a few seconds of code run.
Points to Note
There are some limitations:
- The listing can only work for code that compiles correctly; that is, sensible constructs if not necessarily working code.
- API variable declarations and enumerations of constants are not handled. That is to say, they will not be listed even if they are redundant.
- The module is coded to work with the VBAProject of ThisWorkbook . There is however, an optional parameter to access another workbook object for those who intend to check some other.
- The module works with the usual VBA variable naming methods. This includes the use of public same-names, and fully expressed variable descriptions. It does so by searching for compound similars as well as their simple forms. For example, although rare, the three forms myvar, Module1.myvar, and VBProject.Module1.myvar could all be used in code for the same variable. The use of these forms allows the same variable names to be used in any module heading without conflict.
- Several worksheet listings are made for output results and testing. The user should make sure that sheets 1 to 5 exist, since the code will not create them in this listing. The user might want to restrict or change these in the main procedure if they will conflict with other uses. A separate user form output makes use of procedure AutoLayout.
- The user form styles might not suit everyone, but the colorings and fonts can be changed in two user-sections of the procedure AutoLayout. Bear in mind however, that the chosen font must be monospaced for a neat layout. Apart from this restriction, the layout will handle any regular font size from about 6 to 20 points, as well as the bold and italic variants. That is to say, the code will auto-adjust the userform layout and sizes to produce a useful display.
- Procedures have not been marked as module Private. There is the remote possibility of same-name procedures being encountered when users also make use of other modules in this series. In future I will try to remember to mark them module-private if they look as though they were used elsewhere.
- Interested parties might like to advise of any bugs. Please use only the Discussion page and I will get to them as soon as I can.
Work Method Used
General Preparation
- The general method is to make a declared variables list then test each variable entry to see if it is used.
- The project string contains all of the code in the project. The string is loaded into a work array line by line, and is passed in variants from process to process.
- Procedure, module, and project name information is also added. Every code line is marked with this information.
- Quotes and comments are removed, since they could contain any text at all, and might confuse the decision process.
- Other confusions arise from continuation lines, so these are all joined up into single long lines prior to interpretation.
- Shared label lines and line numbers can also cause difficulty, so labels are given lines of their own, and line numbers are separated prior to any decision process.
- Blank lines are not needed so they are removed. Because there is a changed line count, the project work array is renumbered.
- Each code line is marked with its residential line ranges. Each line is given the code line range for the procedure and for the module in which it resides. This data is then easily found later.
The Declared Variables
- The declared variables list, the array vDec, contains every declared variable in the project.
- It lists all other pertinent data about each variable. The scope of each variable is determined and added. The nominal search line ranges are also added. These are the line ranges suggested at first sight after knowing the scope of the variable. For example, a procedure level declaration would show the procedure line range, and a module-private item the module's line range.
- The variables are marked on vDec when they are found as used. The search sequence is, all of the procedure level variables, then the module private variables, then lastly the public variables. When there are same-name variables with different scopes, this sequence is useful, in that it progressively reduces the required search ranges.
- Every variable is checked for naming ambiguity before deciding which search method to use. Only if there is no names ambiguity can a so-called normal approach be taken; ie; searching the entire nominal line range. Otherwise, the nominal search range needs modified to avoid regions where same-name variables were already found. For example, a module variable search would not look in a procedure where a same-named variable had been both declared and used, but would check anyway if no same-name item were declared there.
- Public and module level variables have to be checked in three names. Variables' full names can include project, module, and variable names, or just module and variable names, in addition to the better known short forms.
- Public variables are handled a bit differently. These variables can exist in each module with the same name. There are two kinds of duplicated names possible for public variables; firstly, there is the kind where there is a public variable with the same name as a variable in any number of procedures, and secondly, there is the kind where the same name is used for a public variable in more than one module heading. In these same-name cases the use of public variables need at least the module and variable name when their use is not in the module where declared.
- Most of the time a public variable's name is entirely unique. That is, there is no other variable in the project with the same name. In this case the use of the variable can be searched throughout the project without restriction.
- If the public variable has no same-names in other module heads, but there are same-names in module or procedure variables, then the whole project must be searched for its use, taking into account line restrictions from modules and procedures where such same-names were already found as used.
- If the public variable has same-name variables in more than one module heading, then the determination of variable use must be handled in two stages;
- The entire project must be searched without restriction using both compound forms of the public variable
- Then search in the module where the public variable is declared, taking account of any procedure restrictions that apply from same-names there.
- After all this, any variables not marked as used can be listed as redundant.
VBA Code Module
Updated and Tested 17 Sep 2017
Modified changed word aliases to similars (15 Jan 2018).
Modified AutoLayout() to avoid wrap back in form. Label length plus 4 spaces now, not 2. (17 Sep 2017).
Added a note on need for VBA Extensibility 5.3 and tested code - working OK.(31 Dec 2016)
Modified AutoLayout() to reduce control count.(17 Nov 2016).
Modified AutoLayout() for better font choice.(16 Nov 2016).
Added simpler options for fonts in AutoLayout().(16 Nov 2016)
Modified code in dynamic arrays and added test mode switch bUseWorkSheets in RunVarChecks().(15 Nov 2016)
Removed one redundant procedure and corrected TrimStr error.(13 Nov 2016)
Corrected code call to NewPubRange() in MarkPubVarUse(). Parameter lines now whole project.(8 Nov 2016)
Changes made to user form display procedures. (7 Nov 2016)
Option Explicit
Option Base 1
Sub TestVars()
'Be sure to set a reference to Visual Basic for Applications Extensibility 5.3
Dim vWB As Variant
'set reference to a workbook
'in the current workbooks collection
Set vWB = ThisWorkbook
RunVarChecks vWB
End Sub
Sub RunVarChecks(Optional vWB As Variant)
'runs a redundant variable check on a workbook's code project
'If no workbook supplied in vWB defaults to this workbook.
'Exclusions: "Declared", "Type" and "Const" declarations.
'CLEARS ALL WORKSHEETS AND REWRITES TO SHEETS 1 TO 5
'WHEN bUseWorkSheets IS TRUE
Dim sht As Worksheet, vDec As Variant, vX As Variant, vAB As Variant
Dim c As Long, n As Long, UDec2 As Long, sLN As Long, vT As Variant
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
Dim vJ As Variant, vK As Variant, vL As Variant, vM As Variant
Dim vP As Variant, vR As Variant, vS As Variant, vN As Variant
Dim vU As Variant, vV As Variant, vW As Variant, vDisp As Variant
Dim sLS As String, sPN As String, sMN As String, sProc As String
Dim sVScope As String, sP As String, bOneToFind As Boolean
Dim bProcNamed As Boolean, bNotFirst As Boolean, Upper As Long
Dim bUseWorkSheets As Boolean
Dim Uform As UserForm
'==================================================================
bUseWorkSheets = False 'when true, overwrites all worksheets
' and displays test data in sheets 1 to 5,
' else when false, userform output only.
'==================================================================
'decide whether to use parameter wb or this one
If IsMissing(vWB) Then
Set vWB = ThisWorkbook
End If
'clear sheets - clears all sheets
'and unloads open userforms
For Each Uform In VBA.UserForms
Unload Uform
Exit For
Next Uform
If bUseWorkSheets = True Then
For Each sht In ThisWorkbook.Worksheets
sht.Activate
sht.Range("A1:Z65536").ClearContents
Next sht
End If
'PREPARE THE PROJECT ARRAY
sP = LoadProject(vP, vWB) '0 view original source data on sheet 1
'=========================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vP, "Sheet1" 'raw project
'=========================================================================
TrimStr vP, vS '1 remove end spc and tabs-not newlines
JoinBrokenLines vS, vW '2 rejoin broken lines-leaves blank lines
RemoveApostFmQuotes vW, vJ '3
RemoveAllComments vJ, vL '4 remove all comments-leaves blank lines
RemoveBlankLines vL, vK '5 remove all blank lines-reduces line count
RemoveQuotes vK, vM '6 remove all double quotes and their contents
SplitAtColons vM, vV '7 make separate statement lines split at colons
NumbersToRow vV, vU, 6 '8 new line count row 6; originals still in row 1
'DO NOT RENUMBER LINES BEYOND MarkLineRanges()
MarkLineRanges vU, vR '9 mark array with line ranges for search later
'=========================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vR, "Sheet2" 'mod project
'=========================================================================
'get bounds of modified project line array
Lb1 = LBound(vR, 1): Ub1 = UBound(vR, 1)
Lb2 = LBound(vR, 2): Ub2 = UBound(vR, 2)
'redim of declared variables array
ReDim vDec(1 To 12, 0 To 0)
ReDim vDisp(1 To 4, 0 To 0)
'MAKE THE DECLARED VARIABLES ARRAY
'get one line of project array at a time
'if a declaration line, parse it and extract variables
'to build the declared variables array vDec
For c = Lb2 To Ub2
DoEvents
'get one line of data from array
sLN = CStr(vR(1, c)) 'original line number
sPN = vR(3, c) 'project name
sMN = vR(4, c) 'module name
sProc = vR(5, c) 'procedure name
sLS = vR(8, c) 'joined line string
'get declared variables from the line string
If sProc <> "" Then bProcNamed = True Else bProcNamed = False
GetDeclaredVariables sLS, bProcNamed, sVScope, vM
If sVScope <> "" Then
'load declared variables array with dec vars for one line
If UBound(vM) >= 1 Then 'it is a declaration line
'mark the source array string as a declaration line
vR(13, c) = "Declaration"
'transfer found line variables to vDec
For n = LBound(vM) To UBound(vM)
ReDim Preserve vDec(1 To 12, 1 To UBound(vDec, 2) + 1)
UDec2 = UBound(vDec, 2) 'vDec line number
vDec(1, UDec2) = vM(n) 'Declared variable
vDec(2, UDec2) = sPN 'Project name
vDec(3, UDec2) = sMN 'Module name
vDec(4, UDec2) = sProc 'Procedure name
vDec(5, UDec2) = sVScope 'Scope of variable
vDec(6, UDec2) = StartOfRng(vR, sVScope, c) 'Nominal line search start
vDec(7, UDec2) = EndOfRng(vR, sVScope, c) 'Nominal line search end
vDec(8, UDec2) = "" 'Used marking
vDec(9, UDec2) = sLN 'Original line number
vDec(10, UDec2) = "" 'Use checked marker
vDec(11, UDec2) = vR(9, c) 'Module start line number
vDec(12, UDec2) = vR(10, c) 'Module end line number
Next n
End If
End If
Next c
EmptyTheDecLines vR, vT '10 replaces line string with empty string-no change line count
'DISPLAY CONDITIONED PROJECT ARRAY ON WORKSHEET
'=========================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vT, "Sheet3" 'mod project
'=========================================================================
'NOTES
'AT THIS POINT vT CONTAINS THE PROJECT LINES SOURCE TO SEARCH FOR USED VARIABLES.
'vT WILL ALSO BE USED TO SEARCH FOR THE USE OF DECLARED VARIABLES LISTED IN vDec.
'vDec LISTS THE INITIAL LINE NUMBERS RANGE FOR USE-SEARCH, THOUGH THESE ARE LATER MODIFIED.
'The use-search sequence is all procprivate, all modprivate, then all varpublic.
'All declared variables marked as used at one stage need not have their search ranges
'searched again at the next. Eg: Same-name procprivate-used could never be Modprivate-used also.
'Same-name varpublic variables could only apply as used where neither procprivate or modprivate.
'Nominally assigned searched ranges are modified after each stage to narrow the search line ranges
'for the next stage.
'Same-name public variables in each of several module heads are not yet handled.
'MARK THE DECLARED VARIABLES ARRAY WITH USE STATUS
'FIRST - MARK USE OF PROCPRIVATE vDec ITEMS
MarkProcVarUse vDec, vT, vN
vDec = vN
MarkModVarUse vDec, vT, vAB
vDec = vAB
MarkPubVarUse vDec, vT, vX
vDec = vX
'DISPLAY DECLARED VARIABLES ARRAY ON WORKSHEET
'=======================================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vDec, "Sheet4" 'declared variables list
'=======================================================================================
'LOAD REDUNDANT VARIABLES RESULTS ARRAY
For n = LBound(vDec, 2) To UBound(vDec, 2)
' check whether or not marked used
If vDec(8, n) = "" Then
'unused variable so transfer details
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vDisp, 2) + 1
ReDim Preserve vDisp(1 To 4, 1 To Upper)
Else
'is first data transfer
'so just use first element
ReDim vDisp(1 To 4, 1 To 1)
Upper = UBound(vDisp, 2)
bNotFirst = True
End If
' transfer variable details to display array
vDisp(1, Upper) = vDec(1, n) 'variable name
vDisp(2, Upper) = vDec(4, n) 'procedure name
vDisp(3, Upper) = vDec(3, n) 'module name
vDisp(4, Upper) = vDec(2, n) 'project name
End If
Next n
' report if none found
If UBound(vDisp, 2) = 0 Then
MsgBox "No redundant variables found for display"
Exit Sub
End If
'DISPLAY REDUNDANT VARIABLES RESULTS ON WORKSHEET
'=========================================================================================
If bUseWorkSheets = True Then PrintArrayToSheet vDisp, "Sheet5" 'redundant variables list
'=========================================================================================
'DISPLAY REDUNDANT VARIABLES RESULTS ON USERFORM
AutoLayout vDisp, 1
End Sub
Function LoadProject(vR As Variant, wb As Variant) As String
' Loads local array with parameter workbook's
' whole VBA project string line by line,
' and other details, and returns in array vR.
' Whole project string can be found in LoadProject.
' Needs set reference to Microsoft VBA Extensibility 5.5
'==============================================
' Local String Array sW() Row Details.
' Each line record in one column
'==============================================
'Row 1: Orig proj line number
'Row 2: Orig line string working
'Row 3: Project name
'Row 4: Module name
'Row 5: Procedure name
'Row 6: Reduced proj line number
'Row 7: Temp use for continuation marking
'Row 8: Rejoined versions of lines
'Row 9: Module start number
'Row 10: Module end number
'Row 11: Procedure start number
'Row 12: Procedure end number
'Row 13: n/a
'Row 14: n/a
'==============================================
Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent
Dim VBMod As VBIDE.CodeModule, ProcKind As VBIDE.vbext_ProcKind
Dim sMod As String, sProj As String, sLine As String
Dim nLines As Long, n As Long, nC As Long, sW() As String
Dim Ub2 As Long
'redim dynamic array
Erase sW()
ReDim sW(1 To 14, 1 To 1)
'get ref to parameter workbook
Set VBProj = wb.VBProject
'loop through VBComponents collection
For Each VBComp In VBProj.VBComponents
Set VBMod = VBComp.CodeModule
nLines = VBMod.CountOfLines
sProj = sProj & VBMod.Lines(1, nLines) 'project string
sMod = VBMod.Lines(1, nLines) 'module string
If nLines <> 0 Then
With VBMod
For n = 1 To nLines
DoEvents
sLine = Trim(.Lines(n, 1)) 'line string
'Debug.Print sLine
'redim array for each record
ReDim Preserve sW(1 To 14, 1 To nC + n)
Ub2 = UBound(sW, 2)
'load lines of each module into array
sW(1, Ub2) = CStr(Ub2) 'orig proj line number
sW(2, Ub2) = sLine 'raw line string working
sW(3, Ub2) = VBProj.Name 'project name
sW(4, Ub2) = VBMod.Name 'module name
sW(5, Ub2) = .ProcOfLine(n, ProcKind) 'procedure name
sW(6, Ub2) = "" 'reduced proj line number
sW(7, Ub2) = "" 'continuation mark working
sW(8, Ub2) = "" 'long joined-up broken lines
sW(9, Ub2) = "" 'Module start number
sW(10, Ub2) = "" 'Module end number
sW(11, Ub2) = "" 'Procedure start number
sW(12, Ub2) = "" 'Procedure end number
sW(13, Ub2) = "" 'n/a
sW(14, Ub2) = "" 'n/a
Next n
End With
End If
nC = nC + nLines 'increment for next redim
Next VBComp
'Debug.Print sproj
LoadProject = sProj
vR = sW()
Set VBProj = Nothing: Set VBComp = Nothing
Set VBMod = Nothing
End Function
Private Sub TrimStr(vA As Variant, vR As Variant)
'trims leading and lagging spaces and tabs
'from all input array vA code lines
'Returns array in vR
Dim n As Long, c As Long
Dim vW As Variant, str As String
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
vW = vA
'modify the line strings of the array
For c = Lb2 To Ub2
'get the line string
str = vW(2, c)
n = Len(str)
Do 'delete tabs and spaces from left of string
If Left(str, 1) = Chr(32) Or Left(str, 1) = Chr(9) Then
n = Len(str)
str = Right(str, n - 1)
Else
'left is done
Exit Do
End If
Loop
Do 'delete tabs and spaces from right of string
If Right(str, 1) = Chr(32) Or Right(str, 1) = Chr(9) Then
n = Len(str)
str = Left(str, n - 1)
Else
'left is done
Exit Do
End If
Loop
'pass back the mod string
vW(2, c) = str
Next c
'transfers
vR = vW
End Sub
Sub JoinBrokenLines(vP As Variant, vR As Variant)
'Identifies and joins lines with continuation marks
'Whole lines placed into row 8
'Marks old broken bits as newlines.
'Newlines are removed later in RemoveBlankLines().
Dim vA As Variant, vW As Variant, IsContinuation As Boolean
Dim str As String, sAccum As String, n As Long, s As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vP, 1): Ub1 = UBound(vP, 1)
Lb2 = LBound(vP, 2): Ub2 = UBound(vP, 2)
ReDim vW(Lb1 To Ub1, Lb2 To Ub2)
'pass to work variable
vW = vP
'mark all lines that have a continuation chara
For n = LBound(vW, 2) To UBound(vW, 2)
str = vW(2, n) 'line string
IsContinuation = str Like "* _"
If IsContinuation Then vW(7, n) = "continuation"
Next n
'mark the start and end of every continuation group
For n = LBound(vW, 2) To (UBound(vW, 2) - 1)
If n = 1 Then 'for the first line only
If vW(7, n) = "continuation" Then vW(8, n) = "SC"
If vW(7, n) = "continuation" And vW(7, n + 1) <> "continuation" _
Then vW(8, n + 1) = "EC"
Else 'for all lines after the first
'find ends
If vW(7, n) = "continuation" And vW(7, n + 1) <> "continuation" Then
vW(8, n + 1) = "EC"
End If
'find starts
If vW(7, n) = "continuation" And vW(7, n - 1) <> "continuation" Then
'If vw(7, n) <> "continuation" And vw(7, n + 1) = "continuation" Then
vW(8, n) = "SC"
End If
End If
Next n
'make single strings from each continuation group
For n = LBound(vW, 2) To (UBound(vW, 2) - 1)
If vW(8, n) = "SC" Then 'group starts
'join strings to make one string per continuation group
s = n
vA = Split(CStr(vW(2, n)), "_")
str = CStr(vA(0))
sAccum = str
Do Until vW(8, s) = "EC"
s = s + 1
'handle other continued parts
vA = Split(CStr(vW(2, s)), "_")
str = CStr(vA(0))
sAccum = sAccum & str
vW(2, s) = Replace(vW(2, s), vW(2, s), vbNewLine)
Loop
vW(8, n) = sAccum 'place at first line level in array
End If
str = ""
sAccum = ""
s = 0
Next n
'write remaining strings into row 8 for consistency
'all string parsing and other work now uses row 8
For n = Lb2 To Ub2
If vW(8, n) = "" Or vW(8, n) = "SC" Or vW(8, n) = "EC" Then
vW(8, n) = Trim(vW(2, n))
End If
Next n
'transfers
vR = vW
End Sub
Sub RemoveApostFmQuotes(vB As Variant, vR As Variant)
'returns array vB as vR with apostrophies removed
'from between sets of double quotes,
'Remainder of quote and double quotes themselves left intact.
'for example s = "Dim eyes (Bob's)" becomes s = "Dim eyes (Bobs)"
Dim str As String, str1 As String, vA As Variant, c As Long
Dim n As Long, m As Long, bUnpaired As Boolean, r As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vB, 1): Ub1 = UBound(vB, 1)
Lb2 = LBound(vB, 2): Ub2 = UBound(vB, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
'set up loop to get one line at a time
For c = Lb2 To Ub2
str = vB(8, c)
'split string at double quotes
If str <> "" Then
vA = Split(str, """")
Else
'empty string
str1 = str
GoTo Transfers
End If
'recombine the splits
m = UBound(vA) - LBound(vA)
'as long as even num of quote pairs
If m Mod 2 = 0 Then
For n = LBound(vA) To UBound(vA)
If n Mod 2 = 0 Then 'even elements
str1 = str1 & vA(n)
Else
'odd elements
'apostrophies removed
str1 = str1 & Replace(vA(n), "'", "")
End If
Next n
Else
'unpaired double quotes detected
bUnpaired = True
End If
Transfers: 'transfer one row only
For r = Lb1 To Ub1
vR(r, c) = vB(r, c)
Next r
'if all pairs matched
If bUnpaired = False Then
vR(8, c) = str1
Else
'exit loop with str
End If
str1 = "" 'reset accumulator
bUnpaired = False
Next c
End Sub
Sub RemoveAllComments(vA As Variant, vR As Variant)
'Removes all comments from vA row 8 line strings
'Includes comments front, middle and end so
'apostrophed text in double quotes would result
'in a false line split if not first removed.
Dim bAny As Boolean, bStart As Boolean, bEnd As Boolean
Dim n As Long, m As Long, c As Long, r As Long
Dim bincluded As Boolean, l As Long, str As String
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, 0 To 0)
For c = Lb2 To Ub2
str = vA(8, c)
'detect any instance of a comment mark
bAny = str Like "*'*"
If Not bAny Then
'go for row INCLUSION action
'with original str
bincluded = True
GoTo Transfers
Else
'comment front, 'middle, or 'end
End If
'find whether or not has comment at front
bStart = str Like "'*"
If bStart Then
'go for row EXCLUSION action
'do not include row at all
bincluded = False
GoTo Transfers
Else
'might still have comment at end
End If
'find whether or not has comment at end
bEnd = str Like "* '*"
If bEnd Then
'remove comment at end
l = Len(str)
For n = 1 To l
If Mid(str, n, 2) = " '" Then
str = Trim(Left(str, n - 1))
'go for row INCLUSION action
'with modified str
bincluded = True
GoTo Transfers
End If
Next n
End If
'decide on how to do the default thing
Transfers:
If bincluded = True Then
'include the current row
m = m + 1
ReDim Preserve vR(Lb1 To Ub1, 1 To m)
For r = Lb1 To Ub1
vR(r, m) = vA(r, c)
Next r
vR(8, m) = str
Else
'do not include the current row
End If
Next c
End Sub
Sub RemoveBlankLines(vA As Variant, vR As Variant)
'removes all blank lines from proj array vA
'and returns with modified array in vR
'Changes line count
Dim vM As Variant, bNotFirst As Boolean
Dim c As Long, r As Long, Upper As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vM(Lb1 To Ub1, 1 To 1)
For c = Lb2 To Ub2
If vA(8, c) <> "" And vA(8, c) <> vbNewLine Then
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vM, 2) + 1
ReDim Preserve vM(Lb1 To Ub1, 1 To Upper)
Else
'is first data transfer
'so just use first element
Upper = UBound(vM, 2)
bNotFirst = True
End If
'transfer data
For r = Lb1 To Ub1
vM(r, Upper) = vA(r, c)
Next r
End If
Next c
vR = vM
End Sub
Sub RemoveQuotes(vB As Variant, vR As Variant)
'returns array vB as vR with all text between pairs
'of double quotes removed, and double quotes themselves
'for example s = "Dim eyes" becomes s =
'A failed quotes pairing returns original string.
Dim str As String, str1 As String, vA As Variant, c As Long
Dim n As Long, m As Long, bUnpaired As Boolean, r As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vB, 1): Ub1 = UBound(vB, 1)
Lb2 = LBound(vB, 2): Ub2 = UBound(vB, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
'set up loop to get one line at a time
For c = Lb2 To Ub2
str = vB(8, c)
'split string at double quotes
If str <> "" Then
vA = Split(str, """")
Else
'empty string
str1 = str
GoTo Transfers
End If
'overwrite odd elements to be empty strings
m = UBound(vA) - LBound(vA)
'as long as even num of quote pairs
If m Mod 2 = 0 Then
For n = LBound(vA) To UBound(vA)
'accum even elements
If n Mod 2 = 0 Then
str1 = str1 & vA(n)
End If
Next n
Else
'unpaired double quotes detected
bUnpaired = True
End If
Transfers: 'transfer one row only
For r = Lb1 To Ub1
vR(r, c) = vB(r, c)
Next r
'if all pairs matched
If bUnpaired = False Then
vR(8, c) = str1
Else
'exit loop with str
End If
str1 = "" 'reset accumulator
bUnpaired = False
Next c
End Sub
Sub SplitAtColons(vA As Variant, vR As Variant)
'Because statements and other lines can be placed
'in line and separated by colons, they must be split.
'Splits such into separate lines and increases line count,
'Input array in vA and returns in vR.
'Note: The space after colon is distinct from named arguments
'that have no space after the colon.
Dim vF As Variant, vW As Variant
Dim n As Long, sLine As String, bNotFirst As Boolean
Dim Elem As Variant, m As Long, Upper As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vW(Lb1 To Ub1, Lb2 To Ub2)
ReDim vR(Lb1 To Ub1, 1 To 1)
'pass to work variable
vW = vA
For n = Lb2 To Ub2 'for each line existing
'get line string
sLine = Trim(vW(8, n))
'decide if has colons
'do the split
vF = Split(sLine, ": ")
'does it contain colons?
If UBound(vF) >= 1 Then 'there were non-arg colons
'make a new line in return array for each elem
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vR, 2) + 1
ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
Else
'is first data transfer
'so just use first element
Upper = UBound(vR, 2)
bNotFirst = True
End If
'transfer line of vW to vR
For m = 1 To 8
vR(m, Upper) = vW(m, n)
Next m
vR(8, Upper) = Elem 'overwrite line string
End If
Next Elem
Else
'no colons - redim array and normal line transfer
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vR, 2) + 1
ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
Else
'is first data transfer
'so just use first element
Upper = UBound(vR, 2)
bNotFirst = True
End If
ReDim Preserve vR(Lb1 To Ub1, 1 To Upper)
'transfer line of vW to vR
For m = Lb1 To Ub1
vR(m, Upper) = vW(m, n)
Next m
End If
Next n
End Sub
Sub NumbersToRow(vA As Variant, vR As Variant, Optional nRow As Long = 6)
'adds renumbering of current array lines to row 6.
'and returns vA array in vR. Original numbers still in row 1.
'Optional row number defaults to 6
Dim n As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
For n = Lb2 To Ub2
vA(nRow, n) = n
Next n
vR = vA
End Sub
Sub MarkLineRanges(vA As Variant, vR As Variant)
'Input array in vA, returned in vR with markings.
'Adds any module and procedure line ranges
'that may apply, for every line of vA. These figures
'will be used for the nominal search line ranges.
Dim nS As Long, sS As String, vW As Variant, n As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vW = vA
'MODULE START RANGE
'get the start point values in place
sS = Trim(vW(4, 1)) 'get first module name
nS = CLng(Trim(vW(6, 1))) 'get line number for first module entry
vW(9, Lb2) = nS
For n = Lb2 To Ub2 - 1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(4, n) = vW(4, n + 1) Then
'still same module name
'so mark start value same
vW(9, n + 1) = nS
Else
'n+1 when not same
sS = vW(4, n + 1)
vW(9, n) = nS
nS = vW(6, n + 1)
vW(9, n + 1) = nS
End If
Next n
'MODULE END RANGE
sS = Trim(vW(4, Ub2)) 'get last module name
nS = CLng(Trim(vW(6, Ub2))) 'get line number for first module entry
vW(10, Ub2) = nS
For n = Ub2 To (Lb2 + 1) Step -1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(4, n) = vW(4, n - 1) Then
'still same module name
'so mark start value same
vW(10, n - 1) = nS
Else
'n+1 when not same
sS = vW(4, n - 1)
vW(10, n) = nS
nS = vW(6, n - 1)
vW(10, n - 1) = nS
End If
Next n
'PROCEDURE START RANGE
'get the start point values in place
sS = Trim(vW(5, 1)) 'get first procedure name
nS = CLng(Trim(vW(6, 1))) 'get line number proc entry
vW(11, Lb2) = nS
For n = Lb2 To Ub2 - 1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(5, n) = vW(5, n + 1) Then
'still same module name
'so mark start value same
vW(11, n + 1) = nS
Else
'n+1 when not same
sS = vW(5, n + 1)
vW(11, n) = nS
nS = vW(6, n + 1)
vW(11, n + 1) = nS
End If
Next n
'PROCEDURE END RANGE
sS = Trim(vW(5, Ub2)) 'get last proc name
nS = CLng(Trim(vW(6, Ub2))) 'get line number proc entry
vW(12, Ub2) = nS
For n = Ub2 To (Lb2 + 1) Step -1
'If vW(5, n) = "" Then 'it is a module entry
'count same items
If vW(5, n) = vW(5, n - 1) Then
'still same module name
'so mark start value same
vW(12, n - 1) = nS
Else
'n+1 when not same
sS = vW(5, n - 1)
vW(12, n) = nS
nS = vW(6, n - 1)
vW(12, n - 1) = nS
End If
Next n
'ADD PUBLIC VARIABLE LINE RANGES
'public variable line ranges need not be marked
'since the whole project line range applies
'transfers
vR = vW
End Sub
Sub GetDeclaredVariables(sLine As String, bProcName As Boolean, sScope As String, vRet As Variant)
'Returns an array of declared variables in line string sLine.
'This is used to build the declared variables array (vDec) in RunVarChecks().
'bProcName input is true if sLine project record lists a procedure name, else false.
'sScope outputs scope of line declarations returned in vRet.
'sScope values are "PROCPRIVATE", "DECLARED", "MODPRIVATE", or "VARPUBLIC"
'=========================================================================
'sScope RETURNS:
'"PROCPRIVATE"; returned if declaration is private to a procedure
'"MODPRIVATE"; returned if declaration is private to a module
'"VARPUBLIC"; returned if declaration is public
'"DECLARED"; returned if declared with keyword "Declared" in heading
'=========================================================================
Dim IsDim As Boolean, nL As Long, vF As Variant
Dim Elem As Variant, vS As Variant, vT As Variant
Dim bPrivate As Boolean, bPublic As Boolean, bStatic As Boolean
Dim bPrivPubStat As Boolean, bDeclare As Boolean, bType As Boolean
Dim bSub As Boolean, bFunc As Boolean, bConst As Boolean
Dim n As Long, Upper As Long, bNotFirst As Boolean
' '----------------------------------------------------------------------------
' Handle exclusions: lines that contain any of the declaration keywords;
' "Declare", "Const", and "Type"
' '----------------------------------------------------------------------------
bDeclare = sLine Like "* Declare *" Or sLine Like "Declare *"
bConst = sLine Like "* Const *" Or sLine Like "Const *"
bType = sLine Like "* Type *" Or sLine Like "Type *"
If bDeclare Or bConst Or bType Then
GoTo DefaultTransfer
End If
'----------------------------------------------------------------------------
' Then, check declarations that were made with the "Dim" statement,
' at private module and at procedure level.
'----------------------------------------------------------------------------
'sLine = "Dim IsDim As Boolean, nL As Long, vF(1 to4,4 to 6,7 to 10) As Variant"
sLine = Trim(sLine)
ReDim vT(0 To 0)
IsDim = sLine Like "Dim *"
'could be proc or module level
If IsDim Then
nL = Len(sLine)
sLine = Right(sLine, nL - 4)
'do the first split
sLine = RemoveVarArgs(sLine)
vF = Split(sLine, ",")
'do the second split
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
vS = Split(Elem, " ")
'Optional might still preceed var name
For n = LBound(vS) To UBound(vS)
If vS(n) <> "Optional" Then
'redim the array
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vT) + 1
ReDim Preserve vT(LBound(vT) To Upper)
Else
'is first data transfer
'so just use first element
ReDim vT(1 To 1)
Upper = UBound(vT)
bNotFirst = True
End If
vT(Upper) = vS(n)
Exit For
End If
Next n
End If
Next Elem
'return results
If UBound(vT, 1) >= 1 Then
If bProcName = True Then
Transfer1: sScope = "PROCPRIVATE"
Else
sScope = "MODPRIVATE"
End If
vRet = vT
Exit Sub 'Function
End If
Else: 'not a dim item so...
GoTo CheckProcLines
End If
CheckProcLines:
'---------------------------------------------------------------------------------
' Check declarations that were made in public and private procedure definitions.
' Procedure definitions made in the module heading with declare are excluded.
'---------------------------------------------------------------------------------
bSub = sLine Like "*Sub *(*[A-z]*)*"
bFunc = sLine Like "*Function *(*[A-z]*)*"
If bSub Or bFunc Then
'obtain contents of first set round brackets
sLine = GetProcArgs(sLine)
'obtain vars without args
sLine = RemoveVarArgs(sLine)
'first split
vF = Split(sLine, ",")
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
'second split
vS = Split(Elem, " ")
'any of Optional, ByVal, ByRef, or ParamArray might preceed var name
For n = LBound(vS) To UBound(vS)
If vS(n) <> "Declare" And vS(n) <> "Optional" And vS(n) <> "ByVal" And _
vS(n) <> "ByRef" And vS(n) <> "ParamArray" Then
'redim the array
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vT) + 1
ReDim Preserve vT(LBound(vT) To Upper)
Else
'is first data transfer
'so just use first element
ReDim vT(1 To 1)
Upper = UBound(vT)
bNotFirst = True
End If
vT(Upper) = vS(n)
Exit For
End If
Next n
End If
Next Elem
'return results if any found in section
If UBound(vT) >= 1 Then
If bProcName = True Then
Transfers2: sScope = "PROCPRIVATE"
Else
'exits with empty sScope
sScope = ""
End If
vRet = vT
Exit Sub
End If
Else 'not a dec proc line so...
GoTo OtherVarDecs
End If
OtherVarDecs:
'--------------------------------------------------------------------------------------------
' Check variable declarations at module level outside of any procedures that
' use the private, public, or static keywords. Dim decs were considered in first section.
'--------------------------------------------------------------------------------------------
'test line for keywords
bSub = sLine Like "* Sub *"
bFunc = sLine Like "* Function *"
bPrivate = sLine Like "Private *"
bPublic = sLine Like "Public *"
bStatic = sLine Like "Static *"
If bPrivate Or bPublic Or bStatic Then bPrivPubStat = True
'exclude module procs but include mod vars
If bConst Then GoTo DefaultTransfer
If bPrivPubStat And Not bSub And Not bFunc Then
'remove variable args brackets altogether
sLine = RemoveVarArgs(sLine)
'first split
vF = Split(sLine, ",")
For Each Elem In vF
Elem = Trim(CStr(Elem))
If Elem <> "" Then
vS = Split(Elem, " ")
'any of private, public, or withEvents could preceed var name
For n = LBound(vS) To UBound(vS)
If vS(n) <> "Private" And vS(n) <> "Public" And _
vS(n) <> "WithEvents" Then
'redim the array
If bNotFirst = True Then
'not first data transfer
'so increment array before transfer
Upper = UBound(vT) + 1
ReDim Preserve vT(LBound(vT) To Upper)
Else
'is first data transfer
'so just use first element
ReDim vT(1 To 1)
Upper = UBound(vT)
bNotFirst = True
End If
vT(Upper) = vS(n)
Exit For
End If
Next n
End If
Next Elem
'return array and results
If UBound(vT) >= 1 Then
If bPrivate Then
Transfers3: sScope = "MODPRIVATE"
ElseIf bPublic Then
sScope = "VARPUBLIC"
End If
vRet = vT
Exit Sub
End If
Else 'not a mod private ,public, etc, so...
GoTo DefaultTransfer
End If
DefaultTransfer:
'no declarations in this line
'so hand back empty vT(0 to 0)
sScope = ""
vRet = vT
End Sub
Function GetProcArgs(str As String) As String
'Extracts and returns content of FIRST set of round brackets
'This releases the procedure arguments bundle,
'Brackets of arguments themselves removed in RemoveVarArgs.
Dim LeadPos As Long, LagPos As Long
Dim LeadCount As Long, LagCount As Long, Length As Long
Dim n As Long, sTemp1 As String, m As Long
Length = Len(Trim(str))
For n = 1 To Length
If Mid(str, n, 1) = "(" Then
LeadCount = LeadCount + 1
LeadPos = n
For m = LeadPos + 1 To Length
If Mid(str, m, 1) = "(" Then
LeadCount = LeadCount + 1
End If
If Mid(str, m, 1) = ")" Then
LagCount = LagCount + 1
End If
If LeadCount = LagCount And LeadCount <> 0 Then
LagPos = m
'extract the string from between Leadcount and LagCount, without brackets
sTemp1 = Mid(str, LeadPos + 1, LagPos - LeadPos - 1)
GetProcArgs = sTemp1 'return
Exit Function
End If
Next m
End If
Next n
End Function
Function RemoveVarArgs(ByVal str As String) As String
'Removes ALL round brackets and their content from str input.
'Returns modified string in function name RemoveVarArgs.
'============================================================
'Notes: REMOVES ALL ROUND BRACKETS AND THEIR CONTENTS
'the string: dim Arr(1 to 3, 3 to (6+3)), Var() as String
'becomes: dim Arr, Var as String
'============================================================
Dim bIsAMatch As Boolean, LeadPos As Long, LagPos As Long
Dim LeadCount As Long, LagCount As Long, Length As Long
Dim n As Long, sTemp1 As String, sTemp2 As String, m As Long
Do
DoEvents
bIsAMatch = str Like "*(*)*"
If Not bIsAMatch Then Exit Do
Length = Len(Trim(str))
For n = 1 To Length
If Mid(str, n, 1) = "(" Then
LeadCount = LeadCount + 1
LeadPos = n
For m = LeadPos + 1 To Length
If Mid(str, m, 1) = "(" Then
LeadCount = LeadCount + 1
End If
If Mid(str, m, 1) = ")" Then
LagCount = LagCount + 1
End If
If LeadCount = LagCount And LeadCount <> 0 Then
LagPos = m
'remove current brackets and all between them
sTemp1 = Mid(str, LeadPos, LagPos - LeadPos + 1)
sTemp2 = Replace(str, sTemp1, "", 1)
str = sTemp2
Exit For
End If
Next m
End If
bIsAMatch = str Like "*(*)*"
If Not bIsAMatch Then Exit For
Next n
LeadCount = 0
LagCount = 0
LeadPos = 0
LagPos = 0
Loop
RemoveVarArgs = str 'return
End Function
Sub EmptyTheDecLines(vA As Variant, vR As Variant)
'Input array in vA, returned in vR modified.
'Overwrites row 8 line string with empty string
'if line is marked in proj array as a declaration line,
'but leaves other parts of that record intact.
Dim c As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
For c = Lb2 To Ub2
If vA(13, c) = "Declaration" Then
vR(8, c) = ""
End If
Next c
End Sub
Function MarkProcVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
'Updates vDec declared variables array with use data for
'variables declared in procedures.
'Takes vDec in vA and returns modified with markup in vR.
'vT is the project code lines array.
Dim sD As String, sL As String, n As Long, m As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
'step through declared variables array names
For n = LBound(vR, 2) To UBound(vR, 2)
'get one declared variable at a time...
sD = vR(1, n)
'for its associated nominal search lines...
For m = vR(6, n) To vR(7, n)
'and if not a declaration line...
If vT(8, m) <> "" And vR(5, n) = "PROCPRIVATE" Then
'get project line to check...
sL = vT(8, m)
'check project line against all use patterns
If PatternCheck(sL, sD) Then
'mark declared var line as used
vR(8, n) = "Used"
Exit For
Else
End If
End If
Next m
Next n
End Function
Function MarkModVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
'Updates vDec declared variables array with use data
'for variables declared at module-private level.
'Takes vDec in vA and returns modified with markup in vR.
'vT is the project code lines array.
Dim sA1 As String, sA2 As String, sL As String, q As Long
Dim sD As String, n As Long, m As Long, vRet As Variant
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
'CHECK MODPRIVATE ALIAS NAMES IN WHOLE MODULES
'without any line restriction
'no harm in doing all modprivate this way first
'step through declared variables array
For n = Lb2 To Ub2
'If item is modprivate...
If vR(5, n) = "MODPRIVATE" Then
'get both alias names for one variable...
sA1 = vR(3, n) & "." & vR(1, n) 'mod.var
sA2 = vR(2, n) & "." & vR(3, n) & "." & vR(1, n) 'proj.mod.var
'for whole module line set...
For m = vR(11, n) To vR(12, n)
'get proj line
sL = vT(8, m)
'check line against vR use patterns...
If PatternCheck(sL, sA1) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
If PatternCheck(sL, sA2) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
Next m
Else
'action for not modprivate
End If
Next n
'then...
'CHECK MODPRIVATE SHORT NAMES AGAINST WHOLE MODULES
'excluding proc lines using vars with same names
'step through declared variables array
For n = Lb2 To Ub2
'if not already found to be used in above section...
If vR(5, n) = "MODPRIVATE" And vR(8, n) <> "Used" Then
'get its usual short form var name
sD = vR(1, n)
'get a modified search range to exclude proc same-names
NewRange vR, n, CLng(vR(6, n)), CLng(vR(7, n)), vRet
'search for pattern match in restricted range
For q = LBound(vRet) To UBound(vRet)
'if not a declaration line, and n is modprivate, and a permitted search line
If vT(8, q) <> "" And vR(5, n) = "MODPRIVATE" And vRet(q) = "" Then
'search in project array with line q
sL = vT(8, q)
If PatternCheck(sL, sD) Then
vR(8, n) = "Used"
Exit For
End If
End If
Next q
End If
Next n
End Function
Function MarkPubVarUse(vA As Variant, vT As Variant, vR As Variant) As Boolean
'Updates vDec declared variables array with use data
'for variables declared as public in module heads.
'Takes vDec in vA and returns modified with markup in vR.
'vT is the project code lines array.
Dim sA1 As String, sA2 As String, sL As String, q As Long
Dim sD As String, n As Long, m As Long, vRet As Variant
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vR(Lb1 To Ub1, Lb2 To Ub2)
vR = vA
GeneralChecks:
'CHECK VARPUBLIC ALIAS NAMES IN WHOLE PROJECT
'DO THIS IN EVERY CASE
'without any line restrictions
'do this for all varpublic items first
'step through declared variables array
For n = Lb2 To Ub2
'If item is varpublic...
If vR(5, n) = "VARPUBLIC" And vR(8, n) <> "Used" Then
'get both alias names for one variable...
sA1 = vR(3, n) & "." & vR(1, n) 'mod.vRr
sA2 = vR(2, n) & "." & vR(3, n) & "." & vR(1, n) 'proj.mod.vRr
'for whole project line set...
For m = LBound(vT, 2) To UBound(vT, 2)
'get proj line
sL = vT(8, m)
'check line against vR use patterns...
If PatternCheck(sL, sA1) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
If PatternCheck(sL, sA2) Then
'mark declared vRriable as used
vR(8, n) = "Used"
Exit For
End If
Next m
End If
Next n
'then...
'CHECK VARPUBLIC SHORT NAME USE DEPENDING ON ANY NAME DUPLICATION
'step through declared variables array
For n = Lb2 To Ub2
'if not already found to be used in above section...
If vR(5, n) = "VARPUBLIC" And vR(8, n) <> "Used" Then
'get its usual var name
sD = vR(1, n)
' Ambiguous returns true if other pub vars use same name
If Ambiguous(vR, n) Then
Ambiguous: 'CHECK VARPUBLIC SHORT NAME USE IN MODULES ONLY -similars already checked fully
'get a modified search range to exclude proc same-names
NewRange vR, n, CLng(vR(11, n)), CLng(vR(12, n)), vRet
'run through newly permitted module search lines
For q = LBound(vRet) To UBound(vRet)
'if not a declaration line, and n is modprivate, and a permitted search line
If vT(8, q) <> "" And vR(5, n) = "VARPUBLIC" And vRet(q) = "" Then
'search in project array with line q
sL = vT(8, q)
If PatternCheck(sL, sD) Then
vR(8, n) = "Used"
Exit For
End If
End If
Next q
Else
Unambiguous: 'resolve use when there is no ambiguous variable duplication anywhere
'CHECK VARPUBLIC SHORT NAME USE IN WHOLE PROJECT
'get a modified search range to exclude proc and module same-names
NewPubRange vR, n, LBound(vT, 2), UBound(vT, 2), vRet
'run through newly permitted project search lines
For q = LBound(vRet) To UBound(vRet)
'if not a declaration line, and n is varpublic, and a permitted search line
If vT(8, q) <> "" And vR(5, n) = "VARPUBLIC" And vRet(q) = "" Then
'search in project array with line q
sL = vT(8, q)
If PatternCheck(sL, sD) Then
vR(8, n) = "Used"
Else
End If
End If
Next q
End If
End If
Next n
End Function
Function Ambiguous(vA As Variant, n As Long) As Boolean
'Returns function name as true if the public variable
'in line number n of vDec has duplicated use of its
'name elsewhere in vDec declared variables listing,
'by another public variable, else it is false.
'Public variables CAN exist with same names.
Dim m As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'step through vDec as vA checking item n against all others
For m = Lb2 To Ub2
'if rows different,names same,projects same,and both varpublic...
If m <> n And vA(1, n) = vA(1, m) And vA(2, n) = vA(2, m) And _
vA(5, n) = "VARPUBLIC" And vA(5, m) = "VARPUBLIC" Then
'there is duplication for public variable name in row n
Ambiguous = True
Exit Function
End If
Next m
End Function
Function NewPubRange(vA As Variant, n As Long, nS As Long, nE As Long, vR As Variant) As Boolean
'Input is vDec array in vA. Returns vR array with search restriction markings.
'Used for public variable use search in MarkPubVarUsewhen there is no ambiguous naming at all.
'The nominal search range is input as nS and nE,and this line range will be marked to search or not.
'Input n is vDec line number for the public variable name that needs a search data range returned.
'vR array elements are marked "X" to avoid that line and "" to search it in the project array.
Dim nSS As Long, nSE As Long
Dim strD As String, m As Long, p As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'set size of return array equal to number of nominal search lines
'that is for this proc the entire project range
ReDim vR(nS To nE)
'get usual var name
strD = vA(1, n)
'search for variable name in declared variables array
For m = Lb2 To Ub2
'if not same rows, and var name same, and project same, and was used...
'then its proc or module search lines all need excluded from project search
If n <> m And strD = vA(1, m) And vA(2, n) = vA(2, m) And vA(8, m) = "Used" Then
'get item's range to exclude
nSS = vA(6, m) 'start nominal range for samename item
nSE = vA(7, m) 'end nominal range for samename item
'mark vR with exclusion marks
For p = nSS To nSE
vR(p) = "X" 'exclude this line
Next p
End If
Next m
NewPubRange = True
End Function
Function NewRange(vA As Variant, n As Long, nS As Long, nE As Long, vR As Variant) As Boolean
'Used for both public and module variable name search. For short form of name.
'Makes an array that is used to restrict the used-var search range.
'nS and nE are start and end nominal search line numbers.
'Input is vDec in vA, n is vDec line number for variable under test, vR is return array.
'returns array vR marked "X" for exclusion of search where a procedure has a
'same-name variable to that of line n in vDec. Restricts the nominal search range.
Dim nSS As Long, nSE As Long
Dim strD As String, m As Long, p As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of vDec input as vA
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'set size of return array equal to number of nominal search lines
ReDim vR(nS To nE)
'get usual var name
strD = vA(1, n)
'search for variable name in declared variables array
For m = Lb2 To Ub2
'if not same rows, and var name same, and project same, and module same, and has a procedure name,
'and was used...then its proc search lines all need excluded from module search
If n <> m And strD = vA(1, m) And vA(2, n) = vA(2, m) And vA(3, n) = vA(3, m) And _
vA(4, m) <> "" And vA(8, m) = "Used" Then 'in a proc
'get item's range to exclude
nSS = vA(6, m) 'start nominal range for samename item
nSE = vA(7, m) 'end nominal range samename item
'mark vR with exclusion marks
For p = nSS To nSE
vR(p) = "X" 'exclude this line
Next p
End If
Next m
NewRange = True
End Function
Function StartOfRng(vA As Variant, sScp As String, n As Long) As Long
'Returns line number in function name that starts nominal search range.
'Information already on the project array.
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'get ranges using new line numbers in row 6
Select Case sScp
Case "PROCPRIVATE"
StartOfRng = vA(11, n)
Case "MODPRIVATE"
StartOfRng = vA(9, n)
Case "VARPUBLIC"
StartOfRng = LBound(vA, 2)
Case "DECLARED"
'StartOfRng = vA(9, n)
Case Else
MsgBox "Dec var scope not found"
End Select
End Function
Function EndOfRng(vA As Variant, sScp As String, n As Long) As Long
'Returns line number in function name for end of used search
'Information already on the project array
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long
'get bounds of project array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
'get ranges using new line numbers in row 6
Select Case sScp
Case "PROCPRIVATE"
EndOfRng = vA(12, n)
Case "MODPRIVATE"
EndOfRng = vA(10, n)
Case "VARPUBLIC"
EndOfRng = UBound(vA, 2)
Case "DECLARED"
'EndOfRng = vA(10, n)
Case Else
MsgBox "Dec var scope not found"
End Select
End Function
Sub PrintArrayToSheet(vA As Variant, sSht As String)
'Used at various points in project to display test info
'Writes input array vA to sSht with top left at cells(1,1)
'Sheet writing assumes lower bound of array is 1
'Makes use of Transpose2DArr()
Dim sht As Worksheet, r As Long, c As Long
Dim Ub1 As Long, Lb1 As Long, Lb2 As Long, Ub2 As Long, vRet As Variant
Transpose2DArr vA, vRet
'get bounds of project array
Lb1 = LBound(vRet, 1): Ub1 = UBound(vRet, 1)
Lb2 = LBound(vRet, 2): Ub2 = UBound(vRet, 2)
If Lb1 <> 0 And Lb2 <> 0 And Ub1 <> 0 And Ub2 <> 0 Then
Set sht = ThisWorkbook.Worksheets(sSht)
sht.Activate
For r = Lb1 To Ub1
For c = Lb2 To Ub2
sht.Cells(r, c) = vRet(r, c)
Next c
Next r
sht.Cells(1, 1).Select
Else
'MsgBox "No redundant variables found."
End If
End Sub
Function Transpose2DArr(ByRef vA As Variant, Optional ByRef vR As Variant) As Boolean
' Used in both user form and sheet output displays.
' Transposes a 2D array of numbers or strings.
' Returns the transposed vA array as vR with vA intact.
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim r As Long, c As Long
'find bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
'set vR dimensions transposed
'If Not IsMissing(vR) Then
If IsArray(vR) Then Erase vR
ReDim vR(loC To hiC, loR To hiR)
'End If
'transfer data
For r = loR To hiR
For c = loC To hiC
'transpose vA into vR
vR(c, r) = vA(r, c)
Next c
Next r
Transfers:
'return success for function
Transpose2DArr = True
End Function
Sub StrToNextRow(sIn As String, sSht As String, Optional nCol As Long = 1)
'Writes to next free row of nCol.
'Optional parameter nCol defaults to unity.
'sIn: String input to display, sSht: Worksheet string name to write to.
Dim sht As Worksheet, nRow As Long
Set sht = ThisWorkbook.Worksheets(sSht)
sht.Activate
nRow = Cells(Rows.Count, nCol).End(xlUp).Row + 1
sht.Cells(nRow, nCol).Activate
ActiveCell.Value = sIn
End Sub
Function PatternCheck(sLine As String, sDec As String) As Boolean
'Used to determine whether or not a declared variable is used.
'Returns PatternCheck as true if sDec was used
'in sLine, else false. sDec is the declared variable
'and sLine is the previously modified code line. Modifications
'removed quotes and comments that can cause error.
'Checks against a set of common use patterns.
'Dim sLine As String, sDec As String
Dim bIsAMatch As Boolean, n As Long
Dim Lb2 As Long, Ub2 As Long
For n = Lb2 To Ub2
'if parameter found in format of pattern returns true - else false
'IN ORDER OF FREQUENCY OF USE;
'PATTERNS FOR FINDING WHETHER OR NOT A VARIABLE IS USED IN A LINE STRING
'A = Var + 1 or A = b + Var + c
bIsAMatch = sLine Like "* " & sDec & " *" 'spaced both sides
If bIsAMatch Then Exit For
'Var = 1
bIsAMatch = sLine Like sDec & " *" 'lead nothing and lag space
If bIsAMatch Then Exit For
'B = Var
bIsAMatch = sLine Like "* " & sDec 'lead space and lag nothing
If bIsAMatch Then Exit For
'Sub Name(Var, etc)
bIsAMatch = sLine Like "*(" & sDec & ",*" 'lead opening bracket and lag comma
If bIsAMatch Then Exit For
'B = C(n + Var)
bIsAMatch = sLine Like "* " & sDec & ")*" 'lead space and lag close bracket
If bIsAMatch Then Exit For
'B = "t" & Var.Name
bIsAMatch = sLine Like "* " & sDec & ".*" 'lead space and lag dot
If bIsAMatch Then Exit For
'B = C(Var + n)
bIsAMatch = sLine Like "*(" & sDec & " *" 'lead open bracket and lag space
If bIsAMatch Then Exit For
'B = (Var)
bIsAMatch = sLine Like "*(" & sDec & ")*" 'lead open bracket and lag close bracket
If bIsAMatch Then Exit For
'Var.Value = 5
bIsAMatch = sLine Like sDec & ".*" 'lead nothing and lag dot
If bIsAMatch Then Exit For
'A = Var(a, b)
'Redim Var(1 to 6, 3 to 8) 'ie: redim is commonly treated as use, but never as declaration.
bIsAMatch = sLine Like "* " & sDec & "(*" 'lead space and lag open bracket
If bIsAMatch Then Exit For
'Var(a) = 1
bIsAMatch = sLine Like sDec & "(*" 'lead nothing and lag open bracket
If bIsAMatch Then Exit For
'B = (Var.Name)
bIsAMatch = sLine Like "*(" & sDec & ".*" 'lead opening bracket and lag dot
If bIsAMatch Then Exit For
'SubName Var, etc
bIsAMatch = sLine Like "* " & sDec & ",*" 'lead space and lag comma
If bIsAMatch Then Exit For
'B = (Var(a) - c)
bIsAMatch = sLine Like "*(" & sDec & "(*" 'with lead open bracket and lag open bracket
If bIsAMatch Then Exit For
'Test Var:=Name
bIsAMatch = sLine Like "* " & sDec & ":*" 'lead space and lag colon
If bIsAMatch Then Exit For
'Test(A:=1, B:=2)
bIsAMatch = sLine Like "*(" & sDec & ":*" 'lead opening bracket and lag colon
If bIsAMatch Then Exit For
'SomeSub str:=Var
bIsAMatch = sLine Like "*:=" & sDec 'lead colon equals and lag nothing
If bIsAMatch Then Exit For
'test arg1:=b, arg2:=A + 1
bIsAMatch = sLine Like "*:=" & sDec & " *" 'lead colon equals and lag space
If bIsAMatch Then Exit For
'test arg1:=b, arg2:=A(1) + 1
bIsAMatch = sLine Like "*:=" & sDec & "(*" 'lead colon equals and lag opening bracket
If bIsAMatch Then Exit For
'SomeSub (str:=Var)
bIsAMatch = sLine Like "*:=" & sDec & ")*" 'lead colon equals and lag closing bracket
If bIsAMatch Then Exit For
'SomeSub str:=Var, etc
bIsAMatch = sLine Like "*:=" & sDec & ",*" 'lead colon equals and lag comma
If bIsAMatch Then Exit For
'SomeSub str:=Var.Value etc
bIsAMatch = sLine Like "*:=" & sDec & ".*" 'lead colon equals and lag dot
If bIsAMatch Then Exit For
'SomeModule.Var.Font.Size = 10
' bIsAMatch = sLine Like "*." & sDec & ".*" 'lead dot and lag dot
' If bIsAMatch Then Exit For
'SomeModule.Var(2) = 5
' bIsAMatch = sLine Like "*." & sDec & "(*" 'lead dot and lag opening bracket
' If bIsAMatch Then Exit For
'SomeModule.Var = 3
' bIsAMatch = sLine Like "*." & sDec & " *" 'lead dot and lag space
' If bIsAMatch Then Exit For
Next n
If bIsAMatch Then
PatternCheck = True
'MsgBox "Match found"
Exit Function
Else
'MsgBox "No match found"
'Exit Function
End If
End Function
Sub AutoLayout(vA As Variant, Optional bTranspose As Boolean = False)
' Takes array vA of say, 4 columns of data and
' displays on textbox in tabular layout.
' Needs a userform called ViewVars and a textbox
' called Textbox1. Code will adjust layout.
' Transpose2DArr used only to return data to (r, c) format.
Dim vB As Variant, vL As Variant, vR As Variant
Dim r As Long, c As Long, m As Long, sS As String
Dim nNumPadSp As Long, TxtLab As Control, MaxFormWidth As Long
Dim sAccum As String, sRowAccum As String, bBold As Boolean
Dim nLineLen As Long, BoxFontSize As Long, BoxFontName As String
Dim sLabAccum As String, nLabPadSp As Long, oUserForm As Object
Dim Backshade As Long, BoxShade As Long, BoxTextShade As Long
Dim ButtonShade As Long, ButtonTextShade As Long
Dim Lb1 As Long, Ub1 As Long, Lb2 As Long, Ub2 As Long
Dim TextLength As Long, bItalic As Boolean
' decide to transpose input or not
If bTranspose = True Then
Transpose2DArr vA, vR
vA = vR
End If
' get bounds of display array
Lb1 = LBound(vA, 1): Ub1 = UBound(vA, 1)
Lb2 = LBound(vA, 2): Ub2 = UBound(vA, 2)
ReDim vL(Lb2 To Ub2) ' make labels array
ReDim vB(Lb2 To Ub2) ' dimension column width array
'--------------------------------------------------------------
' SET USER OPTIONS HERE
'--------------------------------------------------------------
' set the name of the userform made at design time
Set oUserForm = ViewVars
' set limit for form width warning
MaxFormWidth = 800
' make column labels for userform - set empty if not needed
vL = Array("Variable", "Procedure", "Module", "Project")
' colors
Backshade = RGB(31, 35, 44) 'almost black - used
ButtonShade = RGB(0, 128, 128) 'blue-green - not used
BoxShade = RGB(0, 100, 0) 'middle green - used
ButtonTextShade = RGB(230, 230, 230) 'near white - not used
BoxTextShade = RGB(255, 255, 255) 'white - used
' Font details are to be found below
'--------------------------------------------------------------
' find maximum width of array columns
' taking account of label length also
For c = Lb2 To Ub2
m = Len(vL(c)) 'label
For r = Lb1 To Ub1
sS = vA(r, c) 'value
If Len(sS) >= m Then
m = Len(sS)
End If
Next r
'exits with col max array
vB(c) = m
m = 0
Next c
' For testing only
' shows max value of each column
' For c = LB2 To UB2
' MsgBox vB(c)
' Next c
For r = Lb1 To Ub1
For c = Lb2 To Ub2
If c >= Lb2 And c < Ub2 Then
' get padding for current element
nNumPadSp = vB(c) + 2 - Len(vA(r, c))
Else
' get padding for last element
nNumPadSp = vB(c) - Len(vA(r, c))
End If
' accumulate line with element padding
sAccum = sAccum & vA(r, c) & Space(nNumPadSp)
' get typical line length
If r = Lb1 Then
sRowAccum = sRowAccum & vA(Lb1, c) & Space(nNumPadSp)
nLineLen = Len(sRowAccum)
End If
Next c
' accumulate line strings
sAccum = sAccum & vbNewLine
Next r
' accumulate label string
For c = Lb2 To Ub2
If c >= Lb2 And c < Ub2 Then
' get padding for current label
nLabPadSp = vB(c) + 2 - Len(vL(c))
Else
' get padding for last element
nLabPadSp = vB(c) - Len(vL(c))
End If
' accumulate the label line
sLabAccum = sLabAccum & vL(c) & Space(nLabPadSp)
Next c
' load user form
Load oUserForm
'================================================================
' SET FONT DETAILS HERE. THESE AFFECT ALL AUTOSIZING.
'================================================================
BoxFontSize = 12 'say between 6 to 20 points
bBold = True 'True for bold, False for regular
bItalic = False 'True for italics, False for regular
BoxFontName = "Courier" 'or other monospaced fonts eg; Consolas
'================================================================
' make the labels textbox
Set TxtLab = oUserForm.Controls.Add("Forms.TextBox.1", "TxtLab")
' format the labels textbox
With TxtLab
.WordWrap = False
.AutoSize = True 'extends to fit text
.Value = ""
.font.Name = BoxFontName
.font.SIZE = BoxFontSize
.font.Bold = bBold
.font.Italic = bItalic
.ForeColor = BoxTextShade
.Height = 20
.Left = 20
.Top = 15
.Width = 0
.BackStyle = 0
.BorderStyle = 0
.SpecialEffect = 0
End With
'apply string to test label to get length
TxtLab.Value = sLabAccum & Space(4)
TextLength = TxtLab.Width
'MsgBox TextLength
'format userform
With oUserForm
.BackColor = Backshade
.Width = TextLength + 40
.Height = 340
.Caption = "Redundant variables list..."
End With
' check user form is within max width
If oUserForm.Width > MaxFormWidth Then
MsgBox "Form width is excessive"
Unload oUserForm
Exit Sub
End If
'format the data textbox
With oUserForm.TextBox1
.ScrollBars = 3
.WordWrap = True
.MultiLine = True
.EnterFieldBehavior = 1
.BackColor = BoxShade
.font.Name = BoxFontName
.font.SIZE = BoxFontSize
.font.Bold = bBold
.font.Italic = bItalic
.ForeColor = BoxTextShade
.Height = 250
.Left = 20
.Top = 40
.Width = TextLength
.Value = sAccum
End With
'show the user form
oUserForm.Show
End Sub
Array Data To Immediate Window
Summary
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 Notes
- 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 Module
Copy the entire code module into a standard VBA module, save the file as type .xlsm and run the top procedure. Be sure to set monospaced fonts for the VBA editor or the object will have been defeated.
Updates
- 26 Nov 2019: Adjusted DispArrInImmWindow() code to better estimate maximum column width, taking account of imposed decimal places.
Option Explicit
Private Sub testDispArrInImmWindow()
'Run this to display a selection of data arrays
'in the immediate window. Auto formatting
'includes rounding and decimal point alignment.
'Alternative is to print data untouched.
'SET IMMEDIATE WINDOW FONT TO MONOSPACED
'Eg: Consolas or Courier.
Dim vArr As Variant, vArr2 As Variant, sOutput As String
'clear the immediate window
ClearImmWindow
'UNFORMATTED random length alpha strings
RndAlphaToArr vArr, 5, 6 'length setting made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random length alpha strings
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2
'UNFORMATTED random length numbers and decimals
RndNumericToArr vArr, 5, 6 'various settings made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random length numbers and decimals
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2
'UNFORMATTED random alpha and number alternating columns
RndMixedDataToArr vArr, 5, 6 'various settings made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random alpha and number alternating columns
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2, sOutput
'output whole string version to a log file
'WriteToFile sOutput, ThisWorkbook.Path & "\MyLongArray.txt"
End Sub
Private Sub ClearImmWindow()
'NOTES
'Clears VBA immediate window down to the insertion point,
'but not beyond. Not a problem as long as cursor is
'at end of text, but otherwise not.
'Clear manually before any neat work.
'Manual clear method: Ctrl-G then Ctrl-A then Delete.
'Max display in immediate window is 199 lines,
'then top lines are lost as new ones added at bottom.
'No reliable code method exists.
Debug.Print String(200, vbCrLf)
End Sub
Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
Optional ByVal nNumDecs As Integer = 2, _
Optional sOut As String)
'--------------------------------------------------------------------------
'vA : Input 2D array for display in the immediate window.
'sOut: Alternative formatted output string.
'bFormatAlignData : True: applies decimal rounding and decimal alignment,
' False: data untouched with only basic column spacing.
'nNumDecs: Sets the rounding up and down of decimal places.
' Integers do not have zeros added at any time.
'Clear the immediate window before each run for best results.
'The immediate window at best lists 199 lines before overwrite, so
'consider using sOut for large arrays. 'ie; use it in a text file
'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
'so set the font VBA editor or any textbox to Courier or Consolas.
'To set different formats for EVERY column of an array it is best to add
'the formats at loading time with the procedure TabularAlignTxtOrNumber().
'--------------------------------------------------------------------------
'messy when integers are set in array and decimals is set say to 3.
'maybe the measurement of max element width should include a measure
' for any dot or extra imposed decimal places as well
'different for integers and for existing decimals
Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
Dim sPadding As String, sDecFormat As String, sR As String, sE As String
Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
Dim nMaxFieldWidth As Integer, bSkip As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
'get bounds of input array
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
ReDim vD(LB1 To UB1, LB2 To UB2) 'display
ReDim vC(LB2 To UB2) 'column max
'--------------------------------------
'set distance between fixed width
'fields in the output display
nInterFieldSpace = 3
'not now used
nMaxFieldWidth = 14
'--------------------------------------
If nNumDecs < 0 Then
MsgBox "nNumDecs parameter must not be negative - closing"
Exit Sub
End If
'find widest element in each column
'and adjust it for any imposed decimal places
For c = LB2 To UB2
n = 0: m = 0
For r = LB1 To UB1
'get element length
If IsNumeric(vA(r, c)) Then
If Int(vA(r, c)) = vA(r, c) Then 'is integer
n = Len(vA(r, c)) + 1 + nNumDecs
Else 'is not integer
If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
n = Len(vA(r, c))
Else 'add the difference in length as result of imposed decimal places
n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
End If
End If
Else
n = Len(vA(r, c))
End If
If n > m Then m = n 'update if longer
Next r
'store the maximum length
'of data in each column
vC(c) = m
Next c
For c = LB2 To UB2
For r = LB1 To UB1
sE = Trim(vA(r, c))
If bFormatAlignData = False Then
sDecFormat = sE
nP = InStr(sE, ".")
bSkip = True
End If
'make a basic format
If bSkip = False Then
nP = InStr(sE, ".")
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
'alpha
ElseIf IsNumeric(sE) = False Then
sDecFormat = sE
End If
End If
'adjust field width to widest in column
bSkip = False
sPadding = Space$(vC(c))
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'alpha
ElseIf IsNumeric(sE) = False Then
vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
End If
Next r
Next c
'output
sOut = ""
For r = LB1 To UB1
For c = LB2 To UB2
sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
Next c
Debug.Print sR 'print one row in imm window
sOut = sOut & sR & vbCrLf 'accum one row in output string
sR = ""
Next r
sOut = sOut & vbCrLf
Debug.Print vbCrLf
End Sub
Private Sub RndAlphaToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random string lengths
Dim sT As String, sAccum As String, nMinLenStr As Integer
Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
Dim nAsc As Integer, r As Long, c As Long
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set minimum and maximum strings lengths here
nMinLenStr = 2 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
'make one random length string
For n = 1 To nLenWord
nAsc = Int((90 - 65 + 1) * Rnd + 65)
sT = Chr$(nAsc)
sAccum = sAccum & sT
Next n
'store string
vIn(r, c) = sAccum
sAccum = "": sT = ""
Next c
Next r
End Sub
Private Sub RndNumericToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random number lengths
Dim sT1 As String, sT2 As String, nMinLenDec As Integer, sSign As String
Dim sAccum1 As String, sAccum2 As String, nMaxLenDec As Integer
Dim nLenInt As Integer, nLenDecs As Integer, nMinLenInt As Integer
Dim n As Long, r As Long, c As Long, nAsc As Integer, nMaxLenInt As Integer
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenDec = 0 'the minumum decimal part length
nMaxLenDec = 4 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 4 'the maximum integer part length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
'make one random length integer string
For n = 1 To nLenInt
If nLenInt = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
ElseIf nLenInt <> 1 And n = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
Else
nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
End If
sT1 = Chr$(nAsc)
sAccum1 = sAccum1 & sT1
Next n
'make one random length decimal part
For n = 0 To nLenDecs
nAsc = Int((57 - 48 + 1) * Rnd + 48)
sT2 = Chr$(nAsc)
sAccum2 = sAccum2 & sT2
Next n
'decide whether or not a negative number
nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
If nAsc = 5 Then sSign = "-" Else sSign = ""
'store string
If nLenDecs <> 0 Then
vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
Else
vIn(r, c) = CSng(sSign & sAccum1)
End If
sT1 = "": sT2 = ""
sAccum1 = "": sAccum2 = ""
'MsgBox vIn(r, c)
Next c
Next r
End Sub
Private Sub RndMixedDataToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random string lengths
Dim sAccum As String, nMinLenStr As Integer, sSign As String
Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
Dim nAsc As Integer, r As Long, c As Long, nMaxLenDec As Integer
Dim sT As String, sT1 As String, sT2 As String, nMinLenDec As Integer
Dim sAccum1 As String, sAccum2 As String, nMinLenInt As Integer
Dim nLenInt As Integer, nLenDecs As Integer, nMaxLenInt As Integer
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenStr = 3 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
nMinLenDec = 0 'the minumum decimal part length
nMaxLenDec = 4 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 4 'the maximum integer part length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
If c Mod 2 <> 0 Then
nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
'make one random length string
For n = 1 To nLenWord
nAsc = Int((90 - 65 + 1) * Rnd + 65)
sT = Chr$(nAsc)
sAccum = sAccum & sT
Next n
'store string
vIn(r, c) = sAccum
sAccum = "": sT = ""
Else
nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
'make one random length integer string
For n = 1 To nLenInt
If nLenInt = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
ElseIf nLenInt <> 1 And n = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
Else
nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
End If
sT1 = Chr$(nAsc)
sAccum1 = sAccum1 & sT1
Next n
'make one random length decimal part
If nLenDecs <> 0 Then
For n = 1 To nLenDecs
nAsc = Int((57 - 48 + 1) * Rnd + 48)
sT2 = Chr$(nAsc)
sAccum2 = sAccum2 & sT2
Next n
Else
sAccum2 = ""
End If
'decide whether or not a negative number
nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
If nAsc = 5 Then sSign = "-" Else sSign = ""
'store string
If nLenDecs <> 0 Then
vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
Else
vIn(r, c) = CSng(sSign & sAccum1)
End If
sT1 = "": sT2 = ""
sAccum1 = "": sAccum2 = ""
End If
Next c
Next r
End Sub
Sub testNumDecAlign()
'produces examples in immediate window for single entries
'clear the immediate window
ClearImmWindow
Debug.Print "|" & TabularAlignTxtOrNum(Cos(30), 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum("Text Heading", 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum(345.746453, 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum(56.5645, 0, 12) & "|"
Debug.Print vbCrLf
End Sub
Private Function TabularAlignTxtOrNum(vIn As Variant, nNumDecs As Integer, _
nFieldWidth As Integer) As String
'Notes:
'Returns vIn in function name, formatted to given number of decimals,
'and padded for display. VIn can contain an alpha string, a numeric
'string, or a number. nNumDecs is intended number of decimals
'in the output and nFieldWidth is its total padded width.
'Non-numerics are left-aligned and numerics are right-aligned.
'Decimal alignment results when say, all of an array column is
'formatted with the same parameters.
'ASSUMES THAT A MONOSPACED FONT WILL BE USED FOR DISPLAY
Dim sPadding As String, sDecFormat As String
'make a format based on whether numeric and how many decimals
If IsNumeric(vIn) Then
If nNumDecs > 0 Then 'decimals
sDecFormat = Format$(vIn, "0." & String$(nNumDecs, "0"))
Else
sDecFormat = Format$(vIn, "0") 'no decimals
End If
Else
sDecFormat = vIn 'non numeric
End If
'get a space string equal to max width
sPadding = Space$(nFieldWidth)
'combine and limit width
If IsNumeric(vIn) Then
'combine and limit width
TabularAlignTxtOrNum = Right$(sPadding & sDecFormat, nFieldWidth)
Else
TabularAlignTxtOrNum = Left$(sDecFormat & sPadding, nFieldWidth)
End If
End Function
Function WriteToFile(sIn As String, sPath As String) As Boolean
'REPLACES all content of text file with parameter string
'makes file if does not exist
'no layout or formatting - assumes external
Dim Number As Integer
Number = FreeFile 'Get a file number
'write string to file
Open sPath For Output As #Number
Print #Number, sIn
Close #Number
WriteToFile = True
End Function
See Also
Viterbi Simulator in VBA
Summary
This code is made for Excel. It simulates the behavior of a data channel's convolutional coding, though by necessity it concentrates on simple examples. Two rate 1/2 systems are provided; both with three stages, one for generator polynomial (111,110), and the other for (111,101). The code was written to improve understanding of the Wikibooks page A Basic Convolutional Coding Example, but might also be of elementary use for students without other software. The code concentrates on random errors of the type caused by Gaussian noise sources. Blank work sheets can be found in the drop-box below:
|
The Simulator
For each of the two configurations, rudimentary options have been provided. No user form has been included here, the author preferring to modify the settings directly in the top procedure's code. The branch metrics make use of CLOSENESS as opposed to HAMMING DISTANCE. A version using HAMMING DISTANCE can be found on an adjacent page.
- User mode settings allow various combinations of inputs and errors to be applied.
- Both coders produce two bits of output for every one bit of input. The message input (display stream m) can be specified by the user, manually or generated randomly to any given length. The decoder output message is distinguished from the original as m*.
- The user can run one cycle or many. Long cycle averaging is often useful. A message box summarizes the BER (bit error rate) results across all cycles. The user can output the metrics and basic streams for one chosen cycle to the worksheet.
- The coder output is modified to include errors. This simulates the effect of random noise in a transmission channel. The user can set specific errors in exact positions or apply random errors throughout to a specified bit error rate. Recall that error bit positions apply to the output of the coder and that the number of bits there will be double that of the message input.
- The display streams are labeled. The user can display the metrics and streams for a cycle. The streams are:
- m is the original message input to the coder.
- c is the coded output from the coder without any errors.
- r is the received version of the coder output with the applied errors.
- m* is the decoder output, the recovered message.
The VBA Code
The code is provided below in one complete module. Copy the code into a standard module. Set options in the top procedure RunCoding, then run that procedure to obtain a summary of error correcting results. The process will clear Sheet1, so be sure that no other essential work is located there. As an example of setting the options, assume that the intention is to test the performance of the 7,5 configuration with both random inputs and random errors to BER 0.01. Proceed as follows:
- Set nCodePolyGen= 75 to select the 111,101 configuration,
- nModeNumber = 8 for random inputs with random errors,
- nAutoCycles = 100 for the average of 100 blocks,
- nLenAutoInput = 500 to use five hundred bits in each input block,
- nNumCdrFlushBits = 3 to add flushing bits at end of each input block,
- sngBER = 0.01 to apply one percent errors,
- Other options can be ignored for this task.
- Run the procedure RunCodingC. Output for the first cycle will be displayed on sheet one, and a summary for the changed BER across the decoder will appear on a message box when the run is complete.. Re-save the code or press the editor's reset button between runs with new parameters.
The Module
Modification 14/Aug/18; removed column numbers restriction. User responsibility now.
Code Functional 11/Aug/18.
Modification 11/Aug/18; corrected ColourTheErrors() procedure.
Modification 23/Mar/18; removed subroutine Notes as redundant.
Modification 03/Nov/17; added back path edge stream to sheet display.
Modification 01/Nov/17; corrected coding errors.
Modification 31/Oct/17; added back path coloring.
Option Explicit
Sub RunCodingC() ' FOR CLOSENESS METHODS
' Run this procedure with chosen in-code settings to study the cross-decoder performance.
' Runs a Viterbi convolutional coder-decoder simulation for two rate 1/2 algorithms.
' Coder 7,6: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(110), Dfree=4.
' Coder 7,5: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(101), Dfree=5.
' Decoders; Viterbi to match each coder. VBA is coded for CLOSENESS as opposed to Hamming DISTANCE.
' Message inputs can be specified exactly, or randomly with chosen length.
' Error insertion can be exact, or random to a specified BER. Various error pair options exist.
' User set number of cycles and output choice. Message box for an all-cycle summary.
Notes:
' The 7,5 coding algorithm with the higher "free distance" = 5 is better than 7,6's with FD = 4.
' Configuration (7,6) handles single bit errors with error free gaps of at least six bits.
' Configuration (7,6) handles some errored pairs in a limited way for some input conditions.
' Configuration (7,5) handles single bit errors with error free gaps of at least five bits.
' Configuration (7,5) handles errored pairs also, with error free gaps of about 12 -15 bits between such pairs.
' Performance Compared: Random Inputs with Random Errors: For 1Mb total input:
' (7,6): BER 1E-3 in, 4E-6 out: BER 1E-2 in, 6E-4 out.
' (7,5): BER 1E-3 in, 1E-6 out: BER 1E-2 in, 3E-5 out.
Assignments:
Dim oSht As Worksheet, vArr As Variant, vEM As Variant, bLucky As Boolean, vDisp As Variant
Dim sngBerDecIn As Single, sngBER As Single, sngBerMOut As Single, nModeNumber As Integer
Dim LB1 As Long, UB1 As Long, x As Long, nClearErrGap As Long, nNumCdrFlushBits As Long
Dim m As Long, nLenAutoInput As Long, nAutoCycles As Long, rd As Long, cd As Long
Dim r As Long, nLenStream As Long, nMErr As Long, nTotMErr As Long, nTotDIErr As Long
Dim nTotLenStream As Long, nDErr As Long, nLenIntoDec As Long, nCycleToDisplay As Long
Dim nTotMBSent As Long, nTotEBMess As Long, nNumDEPC As Long, nFirst As Long, nCodePolyGen As Integer
Dim sDecodedMessage As String, sDM As String, sChannelRx As String, sChannelTx As String, sEdges As String
Dim sCodedMessage As String, sMessage As String, sMW As String, sFctr As String, vT As Variant
On Error GoTo ErrorHandler
UserSettings:
' Set sheet 1 for output as text
' worksheet will be cleared and overwritten between runs
Set oSht = ThisWorkbook.Worksheets("Sheet1")
' format sheet cells
With oSht.Columns
.NumberFormat = "@"
.Font.Size = 16
End With
oSht.Cells(1, 1).Select
' ================================================================================================================
' ===========================MODE NUMBER DESCRIPTIONS=============================================================
' MODE 1
' manual coder input- type string into variable sMessage
' manual decoder input errors-typed into array variable list vEM
' MODE 2
' manual coder input- type string into variable sMessage
' regular spacing of errors throughout, set gap between two errors
' in nClearErrGap and start position for first in nFirst
' MODE 3
' manual coder input- type string into variable sMessage
' one pair of errors only, gap between two errors is random and start
' position for first is set with nFirst- adjusts to input length
' MODE 4
' manual coder input- type string into variable sMessage
' auto decoder input errors- random errors with BER (bit error rate)
' set in sngBER
' MODE 5
' auto coder input- random input- length set in variable nLenAutoInput
' manual decoder input errors-typed into array variable list vEM
' MODE 6
' auto coder input- random input- length set in variable nLenAutoInput
' regular spacing of errors throughout, set gap between two errors in
' nClearErrGap and start position for first in nFirst
' MODE 7
' auto coder input- random input- length set in variable nLenAutoInput
' one pair of errors only, gap between two errors is random and start
' position for first is set with nFirst- adjusts to input length
' MODE 8
' auto coder input- random input- length set in variable nLenAutoInput
' auto decoder input errors- random errors with BER (bit error rate)
' set in sngBER
' MODE 9
' manual coder input- type string into variable sMessage
' no errors at all - no need to touch error settings
' -goes round error insertion
' MODE 10
' auto coder input- random input- length set in variable nLenAutoInput
' no errors at all - no need to touch error settings
' -goes round error insertion
' ================================================================================================================
' ===========================SET WORKING MODE HERE================================================================
nCodePolyGen = 76 ' options so far are 76 for (2,1,3)(111,110) or 75 for (2,1,3)(111,101)
nModeNumber = 1 ' see meanings above
' ================================================================================================================
' ===========================COMMON PARAMETERS====================================================================
nAutoCycles = 1 ' set the number of cycles to run
nCycleToDisplay = nAutoCycles ' choose the cycle number for the metrics sheet output
' ================================================================================================================
' ===========================RANDOM INPUT BLOCK LENGTH============================================================
' USER SET BIT LENGTH FOR INPUT TO CODER - THE MESSAGE INPUT
nLenAutoInput = 20 ' there will be double this number at decoder input
' ================================================================================================================
' ===========================MANUAL INPUT SETTINGS================================================================
sMessage = "10110" ' for the Wiki page example
' sMessage = "10000" ' gives impulse response 11 10 11 ...00 00 00 for 7,5
' sMessage = "10000" ' gives impulse response 11 11 10 ...00 00 00 for 7,6
' =================================================================================================================
' ===========================SET BER, POSITIONS AND GAPS===========================================================
nClearErrGap = 5 ' modes 2,3,7,and 6 to set an error gap
nNumCdrFlushBits = 2 ' modes 2,3,4,6,7,and 8 to apply message end flushing
sngBER = 0.1 ' modes 4 and 8 to insert specified bit error rate at decoder input
nFirst = 5 ' modes 2,3,6,and 7 to set the first error position at decoder input
' =================================================================================================================
' ===========================MANUALLY SET ERROR PARAMETERS=========================================================
' MANUALLY SET ERROR POSITIONS - arrange list in increasing order. Applies at decoder input
' vEM = Array(21, 28, 35, 42, 49, 56, 62) 'for (7,6). Single errors with gaps of 6 error free bits
' vEM = Array(21, 27, 33, 39, 45, 52, 59) 'for (7,5). Single errors with gaps of 5 error free bits
' vEM = Array(21, 22, 36, 37, 52, 53, 68, 69) 'for (7,5). 4 double errors with gaps around 12 error free bits
' vEM = Array(20, 21)
vEM = Array(3, 9)
' =================================================================================================================
' =================================================================================================================
WORKING:
' CYCLE COUNT DISPLAY SPECIFIC OVERRIDES
Select Case nModeNumber
Case 1, 2, 9
nAutoCycles = 1 ' some modes need only single cycle
nCycleToDisplay = 1
End Select
Application.DisplayStatusBar = True
' RUN A SPECIFIED NUMBER OF CYCLES
For r = 1 To nAutoCycles
DoEvents ' interrupt to handle system requests
Application.StatusBar = (r * 100) \ nAutoCycles & " Percent complete"
' CODE the message stream
' Decide how input is produced for each mode
' and add three zeros for FLUSHING
Select Case nModeNumber
Case 1, 2, 3, 4, 9
If Len(sMessage) < 2 Then MsgBox "Manual input string sMessage is too short - closing": Exit Sub
sMW = sMessage & String(nNumCdrFlushBits, "0") ' manually typed message into an array list
Case 5, 6, 7, 8, 10
If nLenAutoInput < 2 Then MsgBox "Short string length specified -closing": Exit Sub
sMW = AutoRandomInputC(nLenAutoInput) & String(nNumCdrFlushBits, "0") ' auto random message
End Select
' CODER
' obtain a coded message from the input
Select Case nCodePolyGen
Case 76
ConvolutionalCoderT7B6C sMW, sCodedMessage
Case 75
ConvolutionalCoderT7B5C sMW, sCodedMessage
Case Else
MsgBox "Chosen algorithm not found - closing"
Exit Sub
End Select
sChannelTx = sCodedMessage
' check that manual error selection will fit the stream
' auto errors have own checks
Select Case nModeNumber
Case 1, 5
LB1 = LBound(vEM, 1): UB1 = UBound(vEM, 1)
' check whether positions are possible
For x = LB1 To UB1
If vEM(x) > (2 * Len(sMW)) Then
MsgBox "Manually selected bit positions don't fit the stream." & vbCrLf & _
"Increase input length or change the bit positions." & vbCrLf & _
"Closing."
Exit Sub
End If
Next x
End Select
' ERRORS
' ADD ERRORS to sChannelTX to simulate channel noise
' Decide how errors are inserted for each mode
Select Case nModeNumber
Case 1, 5 ' manual error assignment
sChannelRx = AddFixedErrsC(sChannelTx, vEM)
Case 2, 6 ' two error spacing, manual gap and start
sChannelRx = FixedSpacedErrorsC(sChannelTx, nFirst, nClearErrGap, 0)
Case 3, 7 ' two errors only, random gap and manual start
sChannelRx = TwoErrOnlyRndGapC(sChannelTx, nFirst, 0)
Case 4, 8 ' auto random errors to manual BER setting
sChannelRx = InsertBERRndC(sChannelTx, sngBER, 0)
Case 9, 10 ' no errors at all
sChannelRx = sChannelTx
End Select
' DECODER
' DECODE the errored bit stream - proc uses Viterbi algorithm
Select Case nCodePolyGen
Case 76
ConvolutionalDecodeC sChannelRx, sDecodedMessage, sEdges, bLucky, 76, vArr, vT
Case 75
ConvolutionalDecodeC sChannelRx, sDecodedMessage, sEdges, bLucky, 75, vArr, vT
Case Else
MsgBox "Configuration not defined - 75 or 76 only - closing"
Exit Sub
End Select
sDM = sDecodedMessage
' SELECTIVE DISPLAY FOR SHEET - display for any ONE cycle
If Application.ScreenUpdating = True Then Application.ScreenUpdating = False
If r = nCycleToDisplay And nCycleToDisplay <> 0 Then
oSht.Activate
oSht.Cells.ClearContents 'remove text
oSht.Cells.Interior.Pattern = xlNone 'remove color fill
' chosen run metrics to sheet
For rd = LBound(vArr, 2) To UBound(vArr, 2)
For cd = LBound(vArr, 1) To UBound(vArr, 1)
oSht.Cells(rd, cd + 1) = CStr(vArr(cd, rd))
Next cd
Next rd
With oSht ' block in unused nodes and add notes
.Cells(1, 1) = "0"
.Cells(2, 1) = "*"
.Cells(3, 1) = "*"
.Cells(4, 1) = "*"
.Cells(2, 2) = "*"
.Cells(4, 2) = "*"
.Cells(12, 1) = "Notes:": .Cells(12, 2) = "Currently using (" & nCodePolyGen & ") configuration."
.Cells(13, 1) = "m:"
.Cells(14, 1) = "c:"
.Cells(15, 1) = "r:"
.Cells(16, 1) = "r*:"
.Cells(17, 1) = "m*:"
.Cells(13, 2) = "The original message stream:"
.Cells(14, 2) = "The coded output stream:"
.Cells(15, 2) = "The coded output with any channel errors in magenta:"
.Cells(16, 2) = "The back path edge values:"
.Cells(17, 2) = "The recovered message with any remaining errors in red:"
.Cells(18, 2) = "The decoder back path is shown in yellow:"
End With
oSht.Range(Cells(13, 2), Cells(18, 2)).Font.Italic = True
DigitsToSheetRowC sMW, 1, 6, "m" ' message in
DigitsToSheetRowC sChannelTx, 2, 7, "c" ' correctly coded message
DigitsToSheetRowC sChannelRx, 2, 8, "r" ' coded message as received
DigitsToSheetRowC sEdges, 2, 9, "r*" ' back path edge values
DigitsToSheetRowC sDecodedMessage, 1, 10, "m*" ' message out
' tint the back path cells
For cd = LBound(vT, 1) To UBound(vT, 1)
' MsgBox vT(cd, 1) & " " & vT(cd, 2)
oSht.Cells(vT(cd, 1), vT(cd, 2) + 1).Interior.Color = RGB(249, 216, 43) ' yellow-orange
Next cd
End If
' IN-LOOP DATA COLLECTION
' ACCUMULATE DATA across all cycles
nMErr = NumBitsDifferentC(sMW, sDM, nLenStream) ' message errors single cycle
nDErr = NumBitsDifferentC(sChannelRx, sChannelTx, nLenIntoDec) ' num decoder input errors single cycle
nTotLenStream = nTotLenStream + nLenStream ' accum num message bits all cycles
nTotMErr = nTotMErr + nMErr ' accum num message error bits all cycles
nTotDIErr = nTotDIErr + nDErr ' accum num decoder input errors all cycles
' reset cycle error counters
nDErr = 0: nDErr = 0
Next r ' end of main cycle counter
Transfers:
' HIGHLIGHT ERRORS ON WORKSHEET - message bit errors red, changes to back path magenta
ColourTheErrors Len(sMW) 'colours length of input block plus flushing
' PREPARE ALL-CYCLE SUMMARY
nTotMBSent = nTotLenStream ' accum num message bits all cycles
nTotEBMess = nTotMErr ' accum num message err bits all cycles
nNumDEPC = nTotDIErr / nAutoCycles ' num input errors added decoder input each cycle
sngBerDecIn = Round(nTotDIErr / (nTotMBSent * 2), 10) ' channel BER decoder input all cycles
sngBerMOut = Round(nTotEBMess / nTotMBSent, 10) ' message BER decoder output all cycles
If sngBerMOut = 0 Then
sFctr = "Perfect"
Else
sFctr = Round(sngBerDecIn / sngBerMOut, 1) ' BER improvement across decoder
End If
' OUTPUT SUMMARY
MsgBox "Total of all message bits sent : " & nTotMBSent & vbCrLf & _
"Total errored bits in all received messages : " & nTotEBMess & vbCrLf & _
"Number channel errors per cycle : " & nNumDEPC & " in block lengths of : " & nLenIntoDec & vbCrLf & _
"BER applied over all decoder input : " & sngBerDecIn & " : " & sngBerDecIn * 100 & "%" & vbCrLf & _
"BER for all messages out of decoder : " & sngBerMOut & " : " & sngBerMOut * 100 & "%" & vbCrLf & _
"Improvement factor across decoder : " & sFctr
' RESETS
If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
Application.StatusBar = ""
Exit Sub
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case 13 ' early exit for certain settings mistakes
Err.Clear
Exit Sub
Case Else
MsgBox "Error number: " & Err.Number & vbNewLine & _
"Error source: " & Err.Source & vbNewLine & _
"Description: " & Err.Description & vbNewLine
Err.Clear
Exit Sub
End Select
End If
End Sub
Function ConvolutionalCoderT7B5C(ByVal sInBitWord As String, sOut As String)
' rate 1/2 coder; one bit in leads to two bits out
' 3 register equivalent, constraint 3
' generator polynomials are top = (1,1,1) and bottom = (1,0,1)
' taken for output first top then bottom
Dim x0 As Long, x1 As Long, x2 As Long
Dim sOut7 As String, sOut5 As String
Dim n As Long, sOutBitWord As String
If sInBitWord = "" Or Len(sInBitWord) < 5 Then
MsgBox "Longer input required for ConvolutionalCoder - closing"
Exit Function
End If
' itialise all registers with zeros
x0 = 0: x1 = 0: x2 = 0
' run the single input bits through the shift register
For n = 1 To Len(sInBitWord) ' this includes any flushing bits
DoEvents
' shift in one bit
x2 = x1 ' second contents into third position
x1 = x0 ' first contents into second position
x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
' combine register outputs
sOut7 = x0 Xor x1 Xor x2 ' top adder output
sOut5 = x0 Xor x2 ' bottom adder output
' combine and accumulate two adder results
sOutBitWord = sOutBitWord & sOut7 & sOut5
sOut = sOutBitWord
Next n
End Function
Function ConvolutionalCoderT7B6C(ByVal sInBitWord As String, sOut As String)
' rate 1/2 coder; one bit in leads to two bits out
' 3 register equivalent, constraint 3
' generator polynomials are top = (1,1,1) and bottom = (1,1,0)
' taken for output first top then bottom
Dim x0 As Long, x1 As Long, x2 As Long
Dim sOut7 As String, sOut6 As String
Dim n As Long, sOutBitWord As String
If sInBitWord = "" Or Len(sInBitWord) < 5 Then
MsgBox "Longer input required for ConvolutionalCoder - closing"
Exit Function
End If
' itialise all registers with zeros
x0 = 0: x1 = 0: x2 = 0
' run the single input bits through the shift register
For n = 1 To Len(sInBitWord) ' this includes any flushing bits
DoEvents
' shift in one bit
x2 = x1 ' second contents into third position
x1 = x0 ' first contents into second position
x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
' combine register outputs
sOut7 = x0 Xor x1 Xor x2 ' top adder output
sOut6 = x0 Xor x1 ' bottom adder output
' combine and accumulate two adder results
sOutBitWord = sOutBitWord & sOut7 & sOut6
sOut = sOutBitWord
Next n
End Function
Function FixedSpacedErrorsC(ByVal sIn As String, ByVal nStart As Long, ByVal nErrFreeSpace As Long, _
nTail As Long, Optional nErrCount As Long) As String
' returns parameter input string in function name with errors added
' at fixed intervals, set by nERRFreeSpace, the error free space between errors,
' and sequence starts with position nStart. Total number of errors placed is found in option parameter nErrCount
' nTail is the number of end bits to keep clear of errors.
Dim n As Long, nLen As Long, nWLen As Long, sAccum As String, c As Long, sSamp As String, nModBit As Long
' check for an empty input string
If sIn = "" Then
MsgBox "Empty string input in FixedSpacedErrors - closing"
Exit Function
End If
' get length of input less tail piece
nWLen = Len(sIn) - nTail
' check length of input sufficient for parameters
If nWLen - nStart < nErrFreeSpace + 1 Then
MsgBox "Input too short in FixedSpacedErrors - increase length -closing"
Exit Function
End If
' accum the part before the start error
sAccum = Mid$(sIn, 1, nStart - 1)
' modify the bit in start position and accum result
sSamp = Mid$(sIn, nStart, 1)
nModBit = CLng(sSamp) Xor 1
sAccum = sAccum & CStr(nModBit)
nErrCount = 1 ' count one error added
' insert fixed interval errors thereafter
For n = nStart + 1 To nWLen
sSamp = Mid$(sIn, n, 1)
c = c + 1
If c = nErrFreeSpace + 1 And n <= nWLen Then ' do the stuff
c = 0
nModBit = CLng(sSamp Xor 1)
sAccum = sAccum & CStr(nModBit)
nErrCount = nErrCount + 1
Else
sAccum = sAccum & sSamp
End If
Next n
FixedSpacedErrorsC = sAccum
End Function
Function TwoErrOnlyRndGapC(ByVal sIn As String, ByVal nStart As Long, ByVal nTail As Long) As String
' returns input string in function name with only 2 added errors, the first at parameter position and
' the second after a random gap.
' nTail is the number of end bits to keep clear of errors.
Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
' find length free of tail bits
nRange = Len(sIn) - nTail
' check that sIn is long enough
If nRange < nStart + 1 Then
MsgBox "sIn too short for start point in TwoErrOnlyRndGap - closing"
Exit Function
End If
' set number of errors needed
nReqNumErr = 2 ' one start and one random
' dimension an array to hold the work
ReDim vA(1 To Len(sIn), 1 To 3)
' load array col 1 with the input bits
' and mark the start bit for error
For r = LBound(vA, 1) To UBound(vA, 1)
vA(r, 1) = CLng(Mid$(sIn, r, 1))
If r = nStart Then ' mark start bit with flag
vA(r, 2) = 1
End If
Next r
' mark intended positions until right number of
' non-overlapping errors is clear
Do Until nCount = nReqNumErr
nCount = 0 ' since first err in place
DoEvents
' get a sample of row numbers in the working range
nSample = Int((nRange - (nStart + 1) + 1) * Rnd + (nStart + 1))
' error flag added to col 2 of intended row
vA(nSample, 2) = 1 ' 1 denotes intention
' run through array col 1
For c = LBound(vA, 1) To UBound(vA, 1)
' count all intention markers so far
If vA(c, 2) = 1 Then
nCount = nCount + 1
End If
Next c
Loop
' when num errors is right modify the ones flagged
For r = LBound(vA, 1) To UBound(vA, 1)
sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
Next r
TwoErrOnlyRndGapC = sAccum
End Function
Function AddFixedErrsC(ByVal sIn As String, vA As Variant) As String
' returns string in function name with errors added in fixed positions.
' positions are set by one dimensional list in vA array
Dim c As Long, nPosition As Long, UB1 As Long, LB1 As Long
Dim sSamp As String, sWork As String, sSamp2 As String, sAccum As String
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
sWork = sIn
For nPosition = LB1 To UB1 ' 0 to 2 eg
For c = 1 To Len(sWork)
sSamp = Mid$(sWork, c, 1)
If c = vA(nPosition) Then
sSamp2 = (1 Xor CLng(sSamp))
sAccum = sAccum & sSamp2
Else
sAccum = sAccum & sSamp
End If
Next c
sWork = sAccum
sAccum = ""
Next nPosition
AddFixedErrsC = sWork
End Function
Function InsertBERRndC(ByVal sIn As String, ByVal BER As Single, ByVal nTail As Long) As String
' returns input string of bits with added random errors in function name
' number of errors depends on length of sIn and BER parameter
' Set nTail to zero to apply errors to flushing bits too
Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
' find length free of nTail eg, remove flushing
nRange = Len(sIn) - nTail
' find number of errors that are needed
nReqNumErr = CLng(BER * nRange) ' Clng rounds fractions
If nReqNumErr < 1 Then
MsgBox "Requested error rate produces less than one error in InsertBERRnd" & vbCrLf & _
"Increase stream length, or reduce BER, or both - closing"
Exit Function
End If
' dimension an array to hold the work
ReDim vA(1 To Len(sIn), 1 To 3)
' load array col 1 with the input bits
For r = LBound(vA, 1) To UBound(vA, 1)
vA(r, 1) = CLng(Mid$(sIn, r, 1))
Next r
' mark intended positions until right number of
' non-overlapping errors is clear
Do Until nCount = nReqNumErr
nCount = 0
DoEvents
' get a sample of row numbers in the working range
nSample = Int((nRange - 1 + 1) * Rnd + 1)
' error flag added to col 2 of intended row
vA(nSample, 2) = 1 ' 1 denotes intention
' run through array col 1
For c = LBound(vA, 1) To UBound(vA, 1)
' count all intention markers so far
If vA(c, 2) = 1 Then
nCount = nCount + 1
End If
Next c
Loop
' when num errors is right modify the ones flagged
For r = LBound(vA, 1) To UBound(vA, 1)
sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
Next r
InsertBERRndC = sAccum
End Function
Sub ConvolutionalDecodeC(ByVal sIn As String, sOut As String, sOut2 As String, bAmbiguous As Boolean, _
nConfiguration As Long, vRet As Variant, vTint As Variant)
' works with rate 1/2 coder; one bit in leads to two bits out
' 3 register equivalent, constraint 3, generator polynomials are top = (1,1,1) and bottom = (1,1,0) for 7,6
' and (1,1,1) and (1,0,1) for 7,5, selected by parameter nConfiguration= 75 or 76.
' NOTES: All calculations of metrics use maximum closeness as opposed to Hamming distance.
' In branch estimates the lowest total is always discarded.
' If branch metrics are equal, discard the bottom of the two incoming branches.
' Working for metrics assumes position at node with two incoming branches.
' Back track starts at last column's metric maximum then follows survivor paths
' back to state "a" time zero.
Dim aV() As String, vH As Variant, sWIn As String, sPrevStateAccumL As String, sPrevStateAccumU As String
Dim nStartR As Long, nStartC As Long, sEdgeBits As String, sInputBit As String
Dim r As Long, c As Long, nSwapR As Long, nSwapC As Long
Dim nVert As Long, nTime As Long, bUpperPath As Boolean, vW As Variant
Dim sAccumEdgeValues As String, sAccumImpliesBits As String
Dim sCurrState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, sLSOut As String
Dim sBitU As String, sBitL As String, sRcdBits As String, nNumTrans As Long
Dim sProposedAccumU As String, sProposedAccumL As String, sDiscardedU As String, sDiscardedL As String
Dim sNodeAccum As String, sBackStateU As String, sBackStateL As String, nNumHighs As Long
' check that number received is even
sWIn = sIn
If Len(sWIn) Mod 2 = 0 Then
nNumTrans = Len(sWIn) / 2
Else
MsgBox "Odd bit pairing at input decoder -closing"
Exit Sub
End If
' dimension arrays
Erase aV()
ReDim aV(0 To nNumTrans, 1 To 4, 1 To 3) ' x transitions, y states, z node data
ReDim vH(1 To 4, 1 To 3) ' r states, c node data
ReDim vW(0 To nNumTrans, 1 To 4) ' r transitions, c states
ReDim vTint(0 To nNumTrans, 1 To 2)
aV(0, 1, 3) = "0" ' set metric for zero node
' CYCLE LOOP
For nTime = 1 To nNumTrans
For nVert = 1 To 4
DoEvents
' Get incoming branch data for current node
If nConfiguration = 75 Then
GeneralDataT7B5C nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
ElseIf nConfiguration = 76 Then
GeneralDataT7B6C nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
End If
' Get the received bits for the incoming transition
sRcdBits = Mid$(sWIn, (nTime * 2) - 1, 2)
' get the current node's previous states' metrics
If sCurrState = "a" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
If sCurrState = "a" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
If sCurrState = "b" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
If sCurrState = "b" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
If sCurrState = "c" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
If sCurrState = "c" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
If sCurrState = "d" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
If sCurrState = "d" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
' NOTE ON EXCEPTIONS
' Exceptions for transitions 0, 1 and 2. Some redundant, or fewer than two incoming branches.
' Nodes with single incoming branches; mark blind branches same edge value as existing edge,
' and mark their previous metrics as zeros. Because policy for choosing equal metrics is always
' to discard the bottom one, exceptions can then be handled in same loop.
' Zero column is handled entirely by settings for transition 1.
' Apply exceptions settings
If nConfiguration = 75 Then
FrontExceptions75C nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
ElseIf nConfiguration = 76 Then
FrontExceptions76C nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
End If
' Calculate incoming branch metrics and add their previous path metrics to each
sProposedAccumU = GetProposedAccumC(sRcdBits, sUSOut, sPrevStateAccumU)
sProposedAccumL = GetProposedAccumC(sRcdBits, sLSOut, sPrevStateAccumL)
' Decide between the two proposed metrics for the current node
' Accept the higher value branch metric and discard the other
' If same in value, choose the top branch and discard the bottom.
If CLng(sProposedAccumU) > CLng(sProposedAccumL) Then
sDiscardedL = "Discard": sDiscardedU = "Keep"
sNodeAccum = sProposedAccumU
ElseIf CLng(sProposedAccumU) < CLng(sProposedAccumL) Then
sDiscardedL = "Keep": sDiscardedU = "Discard"
sNodeAccum = sProposedAccumL
ElseIf CLng(sProposedAccumU) = CLng(sProposedAccumL) Then
sDiscardedL = "Discard": sDiscardedU = "Keep"
sNodeAccum = sProposedAccumU
End If
' Update the node array with the discard data
aV(nTime, nVert, 1) = sDiscardedU ' whether or not upper incoming discarded
aV(nTime, nVert, 2) = sDiscardedL ' whether or not lower incoming discarded
' Update the node array with the value of path metric for the current node
aV(nTime, nVert, 3) = sNodeAccum ' update work array with metric
' Update return work array with node metric value
vW(nTime, nVert) = CLng(sNodeAccum) ' update return display array with metric
Next nVert
Next nTime
' Transfer last column metric values to a work array
c = nNumTrans ' the last column number
For r = 1 To 4 ' number of rows in every column
vH(r, 1) = CLng(aV(c, r, 3)) ' metrics
vH(r, 2) = CLng(c) ' column where metric found in main array
vH(r, 3) = CLng(r) ' row where metric found in main array
Next r
' Sort the last column values to place highest metric at top
SortMetricsArr2D1KeyC vH, 0, 1, 1 ' and assoc recs are in same row
' Detect start point ambiguity for possible future use
' Count number of entries with same high value in column
nNumHighs = 0
For r = 1 To 4 ' number rows in every column
If vH(1, 1) = vH(r, 1) Then nNumHighs = nNumHighs + 1
Next r
If nNumHighs > 1 Then bAmbiguous = True
' Note the row and column numbers for the back path start point
nStartR = CLng(vH(1, 3)) ' retrieve row number
nStartC = CLng(vH(1, 2)) ' retrieve col number
' add coordinates to vTint
vTint(nStartC, 1) = nStartR
vTint(nStartC, 2) = nStartC
' BACK PATH
' Navigate the back path and extract its data
Do Until nStartC <= 0
DoEvents ' allow system requests
' Find survivor path into this node
' if upperpath is open...
If aV(nStartC, nStartR, 1) = "Keep" Then bUpperPath = True Else bUpperPath = False
' if lower path is open...
If aV(nStartC, nStartR, 2) = "Keep" Then bUpperPath = False Else bUpperPath = True
' Get present state
sCurrState = GetStateFmRowC(nStartR)
' Use present state name to fetch the output bits
If nConfiguration = 75 Then
GetOutputBitsT7B5C sCurrState, bUpperPath, sEdgeBits, sInputBit
ElseIf nConfiguration = 76 Then
GetOutputBitsT7B6C sCurrState, bUpperPath, sEdgeBits, sInputBit
Else
MsgBox "Configuration not defined"
End If
' Accumulate output and input values for hop
sAccumEdgeValues = sEdgeBits & sAccumEdgeValues ' edge values -not used
sAccumImpliesBits = sInputBit & sAccumImpliesBits ' decoded message -used
' Get array coordinates for next node in back path
If nConfiguration = 75 Then
GetPosOfSourceT7B5C nStartR, nStartC, bUpperPath, nSwapR, nSwapC
ElseIf nConfiguration = 76 Then
GetPosOfSourceT7B6C nStartR, nStartC, bUpperPath, nSwapR, nSwapC
Else
MsgBox "Configuration not defined"
End If
' Update the new position coordinates for the next hop
nStartR = nSwapR
nStartC = nSwapC
' add coordinates to vTint
vTint(nStartC, 1) = nStartR
vTint(nStartC, 2) = nStartC
Loop
Transfers:
ReDim vRet(LBound(vW, 1) To UBound(vW, 1), LBound(vW, 2) To UBound(vW, 2))
vRet = vW
sOut = sAccumImpliesBits 'single bit message from back path
sOut2 = sAccumEdgeValues 'double bit back path edge outputs
End Sub
Function GetStateFmRowC(nRow As Long) As String
' returns alpha name of state for parameter
' row position in trellis column
Select Case nRow
Case 1
GetStateFmRowC = "a"
Case 2
GetStateFmRowC = "b"
Case 3
GetStateFmRowC = "c"
Case 4
GetStateFmRowC = "d"
End Select
End Function
Function FrontExceptions75C(ByVal nT As Long, ByVal nV As Long, _
sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
' applies the exceptions for configuration 7,5 - applies to closeness only
If nT = 1 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "0": sPSAU = "0"
ElseIf nT = 1 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "0": sPSAU = "0"
ElseIf nT = 2 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "0"
ElseIf nT = 2 And nV = 2 Then
sLSO = "10": sUSO = "10": sPSAL = "0"
ElseIf nT = 2 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "0"
ElseIf nT = 2 And nV = 4 Then
sLSO = "01": sUSO = "01": sPSAL = "0"
End If
FrontExceptions75C = True
End Function
Function FrontExceptions76C(ByVal nT As Long, ByVal nV As Long, _
sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
' applies the exceptions for configuration 7,5 -applies to closeness only
If nT = 1 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "0": sPSAU = "0"
ElseIf nT = 1 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "0": sPSAU = "0"
ElseIf nT = 2 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "0" ' arbitrarily high
ElseIf nT = 2 And nV = 2 Then
sLSO = "11": sUSO = "11": sPSAL = "0"
ElseIf nT = 2 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "0"
ElseIf nT = 2 And nV = 4 Then
sLSO = "00": sUSO = "00": sPSAL = "0"
End If
FrontExceptions76C = True
End Function
Function SortMetricsArr2D1KeyC(ByRef vA As Variant, _
Optional ByVal bIsAscending As Boolean = True, _
Optional ByVal bIsRowSort As Boolean = True, _
Optional ByVal SortIndex As Long = -1, _
Optional ByRef vRet As Variant) As Boolean
' --------------------------------------------------------------------------------
' Procedure : Sort2DArr
' Purpose : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
' Options include in-place, with the source changed, or
' returned in vRet, with the source array intact.
' Optional parameters default to: ROW SORT in place, ASCENDING,
' using COLUMN ONE as the key.
' --------------------------------------------------------------------------------
Dim condition1 As Boolean, vR As Variant
Dim i As Long, j As Long, y As Long, t As Variant
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim bWasMissing As Boolean
' find bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
' find whether optional vR was initially missing
bWasMissing = IsMissing(vRet)
' If Not bWasMissing Then Set vRet = Nothing
' check input range of SortIndex
If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
Exit Function
Else:
End If
If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
Exit Function
Else:
End If
' pass to a work variable
vR = vA
' steer input options
If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
ROWSORT:
For i = loR To hiR - 1
For j = loR To hiR - 1
If bIsAscending Then
condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
Else
condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
End If
If condition1 Then
For y = loC To hiC
t = vR(j, y)
vR(j, y) = vR(j + 1, y)
vR(j + 1, y) = t
Next y
End If
Next
Next
GoTo Transfers
COLSORT:
For i = loC To hiC - 1
For j = loC To hiC - 1
If bIsAscending Then
condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
Else
condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
End If
If condition1 Then
For y = loR To hiR
t = vR(y, j)
vR(y, j) = vR(y, j + 1)
vR(y, j + 1) = t
Next y
End If
Next
Next
GoTo Transfers
Transfers:
' decide whether to return in vA or vRet
If Not bWasMissing Then
' vRet was the intended return array
' so return vRet leaving vA intact
vRet = vR
Else:
' vRet is not intended return array
' so reload vA with vR
vA = vR
End If
' set return function value
SortMetricsArr2D1KeyC = True
End Function
Function GeneralDataT7B5C(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
sLSOut As String, sBitU As String, sBitL As String) As Boolean
' takes as input nVert as position in trellis column and returns various data for that state
Select Case nVert
Case 1
sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "11": sBitU = "0": sBitL = "0"
Case 2
sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "10": sLSOut = "01": sBitU = "0": sBitL = "0"
Case 3
sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "00": sBitU = "1": sBitL = "1"
Case 4
sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "01": sLSOut = "10": sBitU = "1": sBitL = "1"
Case Else
End Select
GeneralDataT7B5C = True
End Function
Function GeneralDataT7B6C(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
sLSOut As String, sBitU As String, sBitL As String) As Boolean
' takes as input nVert as position in trellis column and returns various data for that state
Select Case nVert
Case 1
sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "10": sBitU = "0": sBitL = "0"
Case 2
sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "11": sLSOut = "01": sBitU = "0": sBitL = "0"
Case 3
sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "01": sBitU = "1": sBitL = "1"
Case 4
sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "00": sLSOut = "10": sBitU = "1": sBitL = "1"
Case Else
End Select
GeneralDataT7B6C = True
End Function
Function GetProposedAccumC(sRcd As String, sOut As String, sPrevStateAccum As String) As String
' returns one branch metric in function based on previous state metric, input, and edge value.
Dim nBit As Long, n As Long, m As Long, nTemp As Long
If sRcd = "" Then sRcd = "00"
For n = 1 To 2
nBit = CLng(Mid$(sOut, n, 1)) Xor CLng(Mid$(sRcd, n, 1))
m = m + nBit
Next n
If sPrevStateAccum = "" Then sPrevStateAccum = "0"
nTemp = Abs(m - 2) + CLng(sPrevStateAccum)
GetProposedAccumC = CStr(nTemp)
End Function
Function GetOutputBitsT7B5C(sState As String, bUpper As Boolean, _
sEdgeBits As String, sInputBit As String) As Boolean
' returns edge value and input given the alpha state name
' and choice of top or bottom branch.
' Applies to incoming branches joining at the node.
Select Case sState
Case "a"
If bUpper = True Then
sEdgeBits = "00"
sInputBit = "0"
Else
sEdgeBits = "11"
sInputBit = "0"
End If
Case "b"
If bUpper = True Then
sEdgeBits = "10"
sInputBit = "0"
Else
sEdgeBits = "01"
sInputBit = "0"
End If
Case "c"
If bUpper = True Then
sEdgeBits = "11"
sInputBit = "1"
Else
sEdgeBits = "00"
sInputBit = "1"
End If
Case "d"
If bUpper = True Then
sEdgeBits = "01"
sInputBit = "1"
Else
sEdgeBits = "10"
sInputBit = "1"
End If
End Select
GetOutputBitsT7B5C = True
End Function
Function GetPosOfSourceT7B5C(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
' returns the array column and row for an incoming branch,
' given its position in trellis column and choice of top or bottom branch.
Dim sNodesState As String
' convert to string state names
Select Case nNodeR
Case 1
sNodesState = "a"
Case 2
sNodesState = "b"
Case 3
sNodesState = "c"
Case 4
sNodesState = "d"
End Select
' for c=0 only
If nNodeC = 0 Then
MsgBox "No source beyond zero column"
Exit Function
End If
' For c>0 only
Select Case sNodesState
Case "a"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "b"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
Case "c"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "d"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
End Select
GetPosOfSourceT7B5C = True
End Function
Function DigitsToSheetRowC(ByVal sIn As String, ByVal nNumGrp As Long, _
ByVal nRow As Long, Optional ByVal sRLabel As String = "*")
' takes string of digits and an option code and distributes bits to worksheet rows
Dim n As Long, c As Long, sSamp As String
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets("Sheet1")
oSht.Activate
If Len(sIn) Mod nNumGrp <> 0 Then
MsgBox "Missing bits for grouping in DigitsToSheetRow - closing"
Exit Function
End If
c = 0
' 101 010 101 010
For n = 1 To (Len(sIn) - nNumGrp + 1) Step nNumGrp
DoEvents
sSamp = Mid$(sIn, n, nNumGrp)
c = c + 1
oSht.Cells(nRow, c + 1) = sSamp
If c >= 16384 Then Exit For
Next n
oSht.Cells(nRow, 1) = sRLabel
End Function
Sub ColourTheErrors(ByVal nLen As Long)
' colors specific data to show errors
' changes to decoder pairs in magenta
' changes between input and output message in red
' marks individual received bit errors in bold yellow
' marking is limited to 256 columns to accommodate Excel 2003
Dim oSht As Worksheet, c As Long, nRow As Long
Set oSht = ThisWorkbook.Worksheets("Sheet1")
oSht.Activate
With oSht.Cells
.Font.Color = RGB(0, 0, 0)
.Font.Bold = False
End With
'clear colours in rows below first four to preserve backpath
For nRow = 5 To 20
oSht.Rows(nRow).Cells.Interior.Pattern = xlNone
Next nRow
For c = 2 To nLen + 1 'this is specified length of the string for display
'Note that Excel versions have different max columns
'Up to user to get it right eg: max 256 for Excel 2003
'block with error colouring
'message errors are in red
If oSht.Cells(10, c) <> oSht.Cells(6, c) Then oSht.Cells(10, c).Interior.Color = vbRed
'received channel errors magenta
If oSht.Cells(7, c) <> oSht.Cells(8, c) Then oSht.Cells(8, c).Interior.Color = vbMagenta
'individual errored character colouring in yellow within magenta block
If Left(oSht.Cells(8, c).Value, 1) <> Left(oSht.Cells(7, c).Value, 1) Then
With oSht.Cells(8, c).Characters(1, 1).Font
.Color = -16711681
.Bold = True
End With
End If
If Right(oSht.Cells(8, c).Value, 1) <> Right(oSht.Cells(7, c).Value, 1) Then
With oSht.Cells(8, c).Characters(2, 1).Font
.Color = -16711681
.Bold = True
End With
End If
Next c
End Sub
Function GetOutputBitsT7B6C(sState As String, bUpper As Boolean, _
sEdgeBits As String, sInputBit As String) As Boolean
' returns edge value and input given the alpha state name
' and choice of top or bottom branch.
' Applies to incoming branches joining at the node.
Select Case sState
Case "a"
If bUpper = True Then
sEdgeBits = "00"
sInputBit = "0"
Else
sEdgeBits = "10"
sInputBit = "0"
End If
Case "b"
If bUpper = True Then
sEdgeBits = "11"
sInputBit = "0"
Else
sEdgeBits = "01"
sInputBit = "0"
End If
Case "c"
If bUpper = True Then
sEdgeBits = "11"
sInputBit = "1"
Else
sEdgeBits = "01"
sInputBit = "1"
End If
Case "d"
If bUpper = True Then
sEdgeBits = "00"
sInputBit = "1"
Else
sEdgeBits = "10"
sInputBit = "1"
End If
End Select
GetOutputBitsT7B6C = True
End Function
Function GetPosOfSourceT7B6C(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
' returns the array column and row for an incoming branch,
' given its position in trellis column and choice of top or bottom branch.
Dim sNodesState As String
' convert to string state names
Select Case nNodeR
Case 1
sNodesState = "a"
Case 2
sNodesState = "b"
Case 3
sNodesState = "c"
Case 4
sNodesState = "d"
End Select
' for c=0 only
If nNodeC = 0 Then
MsgBox "No source beyond zero column"
Exit Function
End If
' For c>0 only
Select Case sNodesState
Case "a"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "b"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
Case "c"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "d"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
End Select
GetPosOfSourceT7B6C = True
End Function
Function AutoRandomInputC(ByVal nLength As Long) As String
' makes a pseudo random string of parameter nLength
Dim n As Long, sSamp As String, sAccum As String
' Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Randomize Timer
For n = 1 To (nLength)
sSamp = CStr(Int((1 - 0 + 1) * Rnd + 0))
sAccum = sAccum & sSamp
Next n
AutoRandomInputC = sAccum
End Function
Function NumBitsDifferentC(ByVal sIn1 As String, ByVal sIn2 As String, Optional nLength As Long) As Long
' compares two binary strings of equal length
' and returns the count of the bits in function name that are different
' It is the Hamming distance between the two bit strings
Dim nErr As Long, n As Long, m As Long
' check that streams are same length for comparison
If Len(sIn1) <> Len(sIn2) Then
MsgBox "Stream lengths do not match in StrDifference - closing"
Exit Function
End If
' 0 and 0 = 0
' 0 and 1 = 1
' 1 and 0 = 1
' 1 and 1 = 0
For n = 1 To Len(sIn1)
nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1)))
m = m + nErr
Next n
Transfers:
nLength = Len(sIn1)
NumBitsDifferentC = m
End Function
See Also
External Links
Viterbi Simulator in VBA 2
Summary
It has been noted that some calculate trellis metrics in different ways. So, this page includes an identical convolutional coding function to that in Viterbi Simulator in VBA. The main difference is that whereas that page displays its metrics in terms of CLOSENESS, this page does so in HAMMING DISTANCE. The code layout differs slightly between the two but the error correction remains the same.
This code is made for Excel. It simulates the behavior of a data channel's convolutional coding, though by necessity it concentrates on simple examples. Two rate 1/2 systems are provided; both with three stages, one for generator polynomial (111,110), and the other for (111,101). The code was written to improve understanding of the Wikibooks page A Basic Convolutional Coding Example, but might also be of elementary use for students without other software. The code concentrates on random errors of the type caused by Gaussian noise sources. Blank work sheets can be found in the drop-box below:
|
The Simulator
For each of the two configurations, rudimentary options have been provided. No user form has been included here, the author preferring to modify the settings directly in the top procedure's code. The branch metrics make use of HAMMING DISTANCE as opposed to CLOSENESS. A version using CLOSENESS can be found on an adjacent page.
- User mode settings allow various combinations of inputs and errors to be applied.
- Both coders produce two bits of output for every one bit of input. The message input (display stream m) can be specified by the user, manually or generated randomly to any given length. The decoder output message is distinguished from the original as m*.
- The user can run one cycle or many. Long cycle averaging is often useful. A message box summarizes the BER (bit error rate) results across all cycles. The user can output the metrics and basic streams for one chosen cycle to the worksheet.
- The coder output is modified to include errors. This simulates the effect of random noise in a transmission channel. The user can set specific errors in exact positions or apply random errors throughout to a specified bit error rate. Recall that error bit positions apply to the output of the coder and that the number of bits there will be double that of the message input.
- The display streams are labeled. The user can display the metrics and streams for a cycle. The streams are:
- m is the original message input to the coder.
- c is the coded output from the coder without any errors.
- r is the received version of the coder output with the applied errors.
- m* is the decoder output, the recovered message.
The VBA Code
The code is provided below in one complete module. Copy the code into a standard module. Set options in the top procedure RunCoding, then run that procedure to obtain a summary of error correcting results. The process will clear Sheet1, so be sure that no other essential work is located there. As an example of setting the options, assume that the intention is to test the performance of the 7,5 configuration with both random inputs and random errors to BER 0.01. Proceed as follows:
- Set nCodePolyGen= 75 to select the 111,101 configuration,
- nModeNumber = 8 for random inputs with random errors,
- nAutoCycles = 100 for the average of 100 blocks,
- nLenAutoInput = 500 to use five hundred bits in each input block,
- nNumCdrFlushBits = 3 to add flushing bits at end of each input block,
- sngBER = 0.01 to apply one percent errors,
- Other options can be ignored for this task.
- Run the procedure RunCoding. Output for the first cycle will be displayed on sheet one, and a summary for the changed BER across the decoder will appear on a message box when the run is complete. Re-save the code or press the editor's reset button between runs with new parameters.
The Module
Modification 14/Aug/18; removed column numbers restriction. User responsibility now.
Code Functional 11/Aug/18.
Modification 11/Aug/18; corrected accumulated errors and procedure ColourTheErrors().
Modification 10/Jan/18; corrected error in name of procedure to run.
Modification 03/Nov/17; added back path edge values stream to sheet display.
Modification 01/Nov/17; corrected errors in coding.
Modification 31/Oct/17; added back path coloring.
Option Explicit
Sub RunCoding() ' FOR HAMMING DISTANCE METHODS
' Run this procedure with chosen in-code settings to study the cross-decoder performance.
' THIS VERSION RUNS AND OUTPUTS METRICS BASED ON HAMMING DISTANCE AS OPPOSED TO CLOSENESS
' Runs a Viterbi convolutional coder-decoder simulation for two rate 1/2 algorithms.
' Coder 7,6: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(110), Dfree=4.
' Coder 7,5: Rate 1/2, constraint=3, gen polynomials top=(111) and bottom=(101), Dfree=5.
' Decoders; Viterbi to match each coder.
' Message inputs can be specified exactly, or randomly with chosen length.
' Error insertion can be exact, or random to a specified BER. Various error pair options exist.
' User set number of cycles and output choice. Message box for an all-cycle summary.
Notes:
' The 7,5 coding algorithm with the higher "free distance" = 5 is better than 7,6's with FD = 4.
' Configuration (7,6) handles single bit errors with error free gaps of at least six bits.
' Configuration (7,6) handles some errored pairs in a limited way for some input conditions.
' Configuration (7,5) handles single bit errors with error free gaps of at least five bits.
' Configuration (7,5) handles errored pairs also, with error free gaps of about 12 -15 bits between such pairs.
' Performance Compared: Random Inputs with Random Errors: For 1Mb total input:
' (7,6): BER 1E-3 in, 4E-6 out: BER 1E-2 in, 6E-4 out.
' (7,5): BER 1E-3 in, 1E-6 out: BER 1E-2 in, 3E-5 out.
Assignments:
Dim oSht As Worksheet, vArr As Variant, vEM As Variant, bLucky As Boolean
Dim sngBerDecIn As Single, sngBER As Single, sngBerMOut As Single, nModeNumber As Integer
Dim LB1 As Long, UB1 As Long, x As Long, nClearErrGap As Long, nNumCdrFlushBits As Long
Dim m As Long, nLenAutoInput As Long, nAutoCycles As Long, rd As Long, cd As Long
Dim r As Long, nLenStream As Long, nMErr As Long, nTotMErr As Long, nTotDIErr As Long
Dim nTotLenStream As Long, nDErr As Long, nLenIntoDec As Long, nCycleToDisplay As Long
Dim nTotMBSent As Long, nTotEBMess As Long, nNumDEPC As Long, nFirst As Long, nCodePolyGen As Integer
Dim sDecodedMessage As String, sDM As String, sChannelRx As String, sChannelTx As String, sEdges As String
Dim sCodedMessage As String, sMessage As String, sMW As String, sFctr As String, vT As Variant
On Error GoTo ErrorHandler
UserSettings:
' Set sheet 1 for output as text
' worksheet will be cleared and overwritten between runs
Set oSht = ThisWorkbook.Worksheets("Sheet1")
' format sheet cells
With oSht.Columns
.NumberFormat = "@"
.Font.Size = 16
End With
oSht.Cells(1, 1).Select
' ================================================================================================================
' ===========================MODE NUMBER DESCRIPTIONS=============================================================
' MODE 1
' manual coder input- type string into variable sMessage
' manual decoder input errors-typed into array variable list vEM
' MODE 2
' manual coder input- type string into variable sMessage
' regular spacing of errors throughout, set gap between two errors
' in nClearErrGap and start position for first in nFirst
' MODE 3
' manual coder input- type string into variable sMessage
' one pair of errors only, gap between two errors is random and start
' position for first is set with nFirst- adjusts to input length
' MODE 4
' manual coder input- type string into variable sMessage
' auto decoder input errors- random errors with BER (bit error rate)
' set in sngBER
' MODE 5
' auto coder input- random input- length set in variable nLenAutoInput
' manual decoder input errors-typed into array variable list vEM
' MODE 6
' auto coder input- random input- length set in variable nLenAutoInput
' regular spacing of errors throughout, set gap between two errors in
' nClearErrGap and start position for first in nFirst
' MODE 7
' auto coder input- random input- length set in variable nLenAutoInput
' one pair of errors only, gap between two errors is random and start
' position for first is set with nFirst- adjusts to input length
' MODE 8
' auto coder input- random input- length set in variable nLenAutoInput
' auto decoder input errors- random errors with BER (bit error rate)
' set in sngBER
' MODE 9
' manual coder input- type string into variable sMessage
' no errors at all - no need to touch error settings
' -goes round error insertion
' MODE 10
' auto coder input- random input- length set in variable nLenAutoInput
' no errors at all - no need to touch error settings
' -goes round error insertion
' ================================================================================================================
' ===========================SET WORKING MODE HERE================================================================
nCodePolyGen = 76 ' options are 76 for (2,1,3)(111,110) or 75 for (2,1,3)(111,101)
nModeNumber = 1 ' see meanings above
' ================================================================================================================
' ===========================COMMON PARAMETERS====================================================================
nAutoCycles = 1 ' set the number of cycles to run
nCycleToDisplay = nAutoCycles ' choose the cycle number for the metrics sheet output
' ================================================================================================================
' ===========================RANDOM INPUT BLOCK LENGTH============================================================
' USER SET BIT LENGTH FOR INPUT TO CODER - THE MESSAGE INPUT
nLenAutoInput = 20 ' there will be double this number at decoder input
' ================================================================================================================
' ===========================MANUAL INPUT SETTINGS================================================================
sMessage = "10110" ' for the Wiki page example
' sMessage = "10110101001" ' for the Wiki page example
' sMessage = "10000" ' gives impulse response 11 10 11 ...00 00 00 for 7,5
' sMessage = "10000" ' gives impulse response 11 11 10 ...00 00 00 for 7,6
' =================================================================================================================
' ===========================SET BER, POSITIONS AND GAPS===========================================================
nClearErrGap = 6 ' modes 2,3,7,and 6 to set an error gap
nNumCdrFlushBits = 2 ' modes 2,3,4,6,7,and 8 to apply message end flushing
sngBER = 0.1 ' modes 4 and 8 to insert specified bit error rate at decoder input
nFirst = 7 ' modes 2,3,6,and 7 to set the first error position at decoder input
' =================================================================================================================
' ===========================MANUALLY SET ERROR PARAMETERS=========================================================
' MANUALLY SET ERROR POSITIONS - arrange list in increasing order. Applies at decoder input
' vEM = Array(21, 28, 35, 42, 49, 56, 62) 'for (7,6). Single errors with gaps of 6 error free bits
' vEM = Array(21, 27, 33, 39, 45, 52, 59) 'for (7,5). Single errors with gaps of 5 error free bits
' vEM = Array(21, 22, 36, 37, 52, 53, 68, 69) 'for (7,5). 4 double errors with gaps around 12 error free bits
' vEM = Array(20, 21)
vEM = Array(3,9)
' =================================================================================================================
' =================================================================================================================
WORKING:
' CYCLE COUNT DISPLAY SPECIFIC OVERRIDES
Select Case nModeNumber
Case 1, 2, 9
nAutoCycles = 1 ' some modes need only single cycle
nCycleToDisplay = 1
End Select
Application.DisplayStatusBar = True
' RUN A SPECIFIED NUMBER OF CYCLES
For r = 1 To nAutoCycles
DoEvents ' interrupt to handle system requests
Application.StatusBar = (r * 100) \ nAutoCycles & " Percent complete"
' CODE the message stream
' Decide how input is produced for each mode
' and add three zeros for FLUSHING
Select Case nModeNumber
Case 1, 2, 3, 4, 9
If Len(sMessage) < 2 Then MsgBox "Manual input string sMessage is too short - closing": Exit Sub
sMW = sMessage & String(nNumCdrFlushBits, "0") ' manually typed message into an array list
Case 5, 6, 7, 8, 10
If nLenAutoInput < 2 Then MsgBox "Short string length specified -closing": Exit Sub
sMW = AutoRandomInput(nLenAutoInput) & String(nNumCdrFlushBits, "0") ' auto random message
End Select
' CODER
' obtain a coded message from the input
Select Case nCodePolyGen
Case 76
ConvolutionalCoderT7B6 sMW, sCodedMessage
Case 75
ConvolutionalCoderT7B5 sMW, sCodedMessage
Case Else
MsgBox "Chosen algorithm not found - closing"
Exit Sub
End Select
sChannelTx = sCodedMessage
' check that manual error selection will fit the stream
' auto errors have own checks
Select Case nModeNumber
Case 1, 5
LB1 = LBound(vEM, 1): UB1 = UBound(vEM, 1)
' check whether positions are possible
For x = LB1 To UB1
If vEM(x) > (2 * Len(sMW)) Then
MsgBox "Manually selected bit positions don't fit the stream." & vbCrLf & _
"Increase input length or change the bit positions." & vbCrLf & _
"Closing."
Exit Sub
End If
Next x
End Select
' ERRORS
' ADD ERRORS to sChannelTX to simulate channel noise
' Decide how errors are inserted for each mode
Select Case nModeNumber
Case 1, 5 ' manual error assignment
sChannelRx = AddFixedErrs(sChannelTx, vEM)
Case 2, 6 ' two error spacing, manual gap and start
sChannelRx = FixedSpacedErrors(sChannelTx, nFirst, nClearErrGap, 0)
Case 3, 7 ' two errors only, random gap and manual start
sChannelRx = TwoErrOnlyRndGap(sChannelTx, nFirst, 0)
Case 4, 8 ' auto random errors to manual BER setting
sChannelRx = InsertBERRnd(sChannelTx, sngBER, 0)
Case 9, 10 ' no errors at all
sChannelRx = sChannelTx
End Select
' DECODER
' using a Viterbi trellis algorithm
Select Case nCodePolyGen
Case 75
ConvolutionalDecodeD sChannelRx, sDecodedMessage, sEdges, bLucky, 75, vArr, vT
Case 76
ConvolutionalDecodeD sChannelRx, sDecodedMessage, sEdges, bLucky, 76, vArr, vT
Case Else
MsgBox "Chosen algorithm not found - closing"
Exit Sub
End Select
sDM = sDecodedMessage
' SELECTIVE DISPLAY FOR SHEET - display for any ONE cycle
If Application.ScreenUpdating = True Then Application.ScreenUpdating = False
If r = nCycleToDisplay And nCycleToDisplay <> 0 Then
oSht.Activate
oSht.Cells.ClearContents 'remove text
oSht.Cells.Interior.Pattern = xlNone 'remove color fill
' chosen run metrics to sheet
For rd = LBound(vArr, 2) To UBound(vArr, 2)
For cd = LBound(vArr, 1) To UBound(vArr, 1)
oSht.Cells(rd, cd + 1) = CStr(vArr(cd, rd))
Next cd
Next rd
With oSht ' block in unused nodes and add notes
.Cells(1, 1) = "0"
.Cells(2, 1) = "*"
.Cells(3, 1) = "*"
.Cells(4, 1) = "*"
.Cells(2, 2) = "*"
.Cells(4, 2) = "*"
.Cells(12, 1) = "Notes:": .Cells(12, 2) = "Currently using (" & nCodePolyGen & ") configuration."
.Cells(13, 1) = "m:"
.Cells(14, 1) = "c:"
.Cells(15, 1) = "r:"
.Cells(16, 1) = "r*:"
.Cells(17, 1) = "m*:"
.Cells(13, 2) = "The original message stream:"
.Cells(14, 2) = "The coded output stream:"
.Cells(15, 2) = "The coded output with any channel errors in magenta:"
.Cells(16, 2) = "The back path edge values:"
.Cells(17, 2) = "The recovered message with any remaining errors in red:"
.Cells(18, 2) = "The decoder back path is shown in yellow:"
End With
oSht.Range(Cells(13, 2), Cells(18, 2)).Font.Italic = True
DigitsToSheetRow sMW, 1, 6, "m" ' message in
DigitsToSheetRow sChannelTx, 2, 7, "c" ' correctly coded message
DigitsToSheetRow sChannelRx, 2, 8, "r" ' coded message as received
DigitsToSheetRow sEdges, 2, 9, "r*" ' back path edge values
DigitsToSheetRow sDecodedMessage, 1, 10, "m*" ' message out
' tint the back path cells
For cd = LBound(vT, 1) To UBound(vT, 1)
' MsgBox vT(cd, 1) & " " & vT(cd, 2)
oSht.Cells(vT(cd, 1), vT(cd, 2) + 1).Interior.Color = RGB(249, 216, 43) ' yellow-orange
Next cd
End If
' IN-LOOP DATA COLLECTION
' ACCUMULATE DATA across all cycles
nMErr = NumBitsDifferent(sMW, sDM, nLenStream) ' message errors single cycle
nDErr = NumBitsDifferent(sChannelRx, sChannelTx, nLenIntoDec) ' num decoder input errors single cycle
nTotLenStream = nTotLenStream + nLenStream ' accum num message bits all cycles
nTotMErr = nTotMErr + nMErr ' accum num message error bits all cycles
nTotDIErr = nTotDIErr + nDErr ' accum num decoder input errors all cycles
' reset cycle error counters
nDErr = 0: nDErr = 0
Next r ' end of main cycle counter
Transfers:
' HIGHLIGHT ERRORS ON WORKSHEET - message bit errors red, changes to back path magenta
ColourTheErrors Len(sMW) ' mark input and output errors for block length and flushing
' PREPARE ALL-CYCLE SUMMARY
nTotMBSent = nTotLenStream ' accum num message bits all cycles
nTotEBMess = nTotMErr ' accum num message err bits all cycles
nNumDEPC = nTotDIErr / nAutoCycles ' num input errors added decoder input each cycle
sngBerDecIn = Round(nTotDIErr / (nTotMBSent * 2), 10) ' channel BER decoder input all cycles
sngBerMOut = Round(nTotEBMess / nTotMBSent, 10) ' message BER decoder output all cycles
If sngBerMOut = 0 Then
sFctr = "Perfect"
Else
sFctr = Round(sngBerDecIn / sngBerMOut, 1) ' BER improvement across decoder
End If
' OUTPUT SUMMARY
MsgBox "Total of all message bits sent : " & nTotMBSent & vbCrLf & _
"Total errored bits in all received messages : " & nTotEBMess & vbCrLf & _
"Number channel errors per cycle : " & nNumDEPC & " in block lengths of : " & nLenIntoDec & vbCrLf & _
"BER applied over all decoder input : " & sngBerDecIn & " : " & sngBerDecIn * 100 & "%" & vbCrLf & _
"BER for all messages out of decoder : " & sngBerMOut & " : " & sngBerMOut * 100 & "%" & vbCrLf & _
"Improvement factor across decoder : " & sFctr
' RESETS
If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
Application.StatusBar = ""
Exit Sub
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case 13 ' early exit for certain settings mistakes
Err.Clear
Exit Sub
Case Else
MsgBox "Error number: " & Err.Number & vbNewLine & _
"Error source: " & Err.Source & vbNewLine & _
"Description: " & Err.Description & vbNewLine
Err.Clear
Exit Sub
End Select
End If
End Sub
Function ConvolutionalCoderT7B5(ByVal sInBitWord As String, sOut As String)
' rate 1/2 coder; one bit in leads to two bits out
' 3 register equivalent, constraint 3
' generator polynomials are top = (1,1,1) and bottom = (1,0,1)
' taken for output first top then bottom
Dim x0 As Long, x1 As Long, x2 As Long
Dim sOut7 As String, sOut5 As String
Dim n As Long, sOutBitWord As String
If sInBitWord = "" Or Len(sInBitWord) < 5 Then
MsgBox "Longer input required for ConvolutionalCoder - closing"
Exit Function
End If
' itialise all registers with zeros
x0 = 0: x1 = 0: x2 = 0
' run the single input bits through the shift register
For n = 1 To Len(sInBitWord) ' this includes any flushing bits
DoEvents
' shift in one bit
x2 = x1 ' second contents into third position
x1 = x0 ' first contents into second position
x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
' combine register outputs
sOut7 = x0 Xor x1 Xor x2 ' top adder output
sOut5 = x0 Xor x2 ' bottom adder output
' combine and accumulate two adder results
sOutBitWord = sOutBitWord & sOut7 & sOut5
sOut = sOutBitWord
Next n
End Function
Function ConvolutionalCoderT7B6(ByVal sInBitWord As String, sOut As String)
' rate 1/2 coder; one bit in leads to two bits out
' 3 register equivalent, constraint 3
' generator polynomials are top = (1,1,1) and bottom = (1,1,0)
' taken for output first top then bottom
Dim x0 As Long, x1 As Long, x2 As Long
Dim sOut7 As String, sOut6 As String
Dim n As Long, sOutBitWord As String
If sInBitWord = "" Or Len(sInBitWord) < 5 Then
MsgBox "Longer input required for ConvolutionalCoder - closing"
Exit Function
End If
' itialise all registers with zeros
x0 = 0: x1 = 0: x2 = 0
' run the single input bits through the shift register
For n = 1 To Len(sInBitWord) ' this includes any flushing bits
DoEvents
' shift in one bit
x2 = x1 ' second contents into third position
x1 = x0 ' first contents into second position
x0 = CLng(Mid(sInBitWord, n, 1)) ' new bit into first
' combine register outputs
sOut7 = x0 Xor x1 Xor x2 ' top adder output
sOut6 = x0 Xor x1 ' bottom adder output
' combine and accumulate two adder results
sOutBitWord = sOutBitWord & sOut7 & sOut6
sOut = sOutBitWord
Next n
End Function
Function FixedSpacedErrors(ByVal sIn As String, ByVal nStart As Long, ByVal nErrFreeSpace As Long, _
nTail As Long, Optional nErrCount As Long) As String
' returns parameter input string in function name with errors added
' at fixed intervals, set by nERRFreeSpace, the error free space between errors,
' and sequence starts with position nStart. Total number of errors placed is found in option parameter nErrCount
' nTail is the number of end bits to keep clear of errors.
Dim n As Long, nWLen As Long, sAccum As String, c As Long, sSamp As String, nModBit As Long
' check for an empty input string
If sIn = "" Then
MsgBox "Empty string input in FixedSpacedErrors - closing"
Exit Function
End If
' get length of input less tail piece
nWLen = Len(sIn) - nTail
' check length of input sufficient for parameters
If nWLen - nStart < nErrFreeSpace + 1 Then
MsgBox "Input too short in FixedSpacedErrors - increase length -closing"
Exit Function
End If
' accum the part before the start error
sAccum = Mid$(sIn, 1, nStart - 1)
' modify the bit in start position and accum result
sSamp = Mid$(sIn, nStart, 1)
nModBit = CLng(sSamp) Xor 1
sAccum = sAccum & CStr(nModBit)
nErrCount = 1 ' count one error added
' insert fixed interval errors thereafter
For n = nStart + 1 To nWLen
sSamp = Mid$(sIn, n, 1)
c = c + 1
If c = nErrFreeSpace + 1 And n <= nWLen Then ' do the stuff
c = 0
nModBit = CLng(sSamp Xor 1)
sAccum = sAccum & CStr(nModBit)
nErrCount = nErrCount + 1
Else
sAccum = sAccum & sSamp
End If
Next n
FixedSpacedErrors = sAccum
End Function
Function TwoErrOnlyRndGap(ByVal sIn As String, ByVal nStart As Long, ByVal nTail As Long) As String
' returns input string in function name with only 2 added errors, the first at parameter position and
' the second after a random gap.
' nTail is the number of end bits to keep clear of errors.
Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
' find length free of tail bits
nRange = Len(sIn) - nTail
' check that sIn is long enough
If nRange < nStart + 1 Then
MsgBox "sIn too short for start point in TwoErrOnlyRndGap - closing"
Exit Function
End If
' set number of errors needed
nReqNumErr = 2 ' one start and one random
' dimension an array to hold the work
ReDim vA(1 To Len(sIn), 1 To 3)
' load array col 1 with the input bits
' and mark the start bit for error
For r = LBound(vA, 1) To UBound(vA, 1)
vA(r, 1) = CLng(Mid$(sIn, r, 1))
If r = nStart Then ' mark start bit with flag
vA(r, 2) = 1
End If
Next r
' mark intended positions until right number of
' non-overlapping errors is clear
Do Until nCount = nReqNumErr
nCount = 0 ' since first err in place
DoEvents
' get a sample of row numbers in the working range
nSample = Int((nRange - (nStart + 1) + 1) * Rnd + (nStart + 1))
' error flag added to col 2 of intended row
vA(nSample, 2) = 1 ' 1 denotes intention
' run through array col 1
For c = LBound(vA, 1) To UBound(vA, 1)
' count all intention markers so far
If vA(c, 2) = 1 Then
nCount = nCount + 1
End If
Next c
Loop
' when num errors is right modify the ones flagged
For r = LBound(vA, 1) To UBound(vA, 1)
sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
Next r
TwoErrOnlyRndGap = sAccum
End Function
Function AddFixedErrs(ByVal sIn As String, vA As Variant) As String
' returns string in function name with errors added in fixed positions.
' positions are set by one dimensional list in vA array
Dim c As Long, nPosition As Long, UB1 As Long, LB1 As Long
Dim sSamp As String, sWork As String, sSamp2 As String, sAccum As String
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
sWork = sIn
For nPosition = LB1 To UB1 ' 0 to 2 eg
For c = 1 To Len(sWork)
sSamp = Mid$(sWork, c, 1)
If c = vA(nPosition) Then
sSamp2 = (1 Xor CLng(sSamp))
sAccum = sAccum & sSamp2
Else
sAccum = sAccum & sSamp
End If
Next c
sWork = sAccum
sAccum = ""
Next nPosition
AddFixedErrs = sWork
End Function
Function InsertBERRnd(ByVal sIn As String, ByVal BER As Single, ByVal nTail As Long) As String
' returns input string of bits with added random errors in function name
' number of errors depends on length of sIn and BER parameter
' Set nTail to zero to apply errors to flushing bits too
Dim nReqNumErr As Long, nSample As Long, r As Long, c As Long
Dim vA() As Long, nRange As Long, nCount As Long, sAccum As String
' find length free of nTail eg, remove flushing
nRange = Len(sIn) - nTail
' find number of errors that are needed
nReqNumErr = CLng(BER * nRange) ' Clng rounds fractions
If nReqNumErr < 1 Then
MsgBox "Requested error rate produces less than one error in InsertBERRnd" & vbCrLf & _
"Increase stream length, or reduce BER, or both - closing"
Exit Function
End If
' dimension an array to hold the work
ReDim vA(1 To Len(sIn), 1 To 3)
' load array col 1 with the input bits
For r = LBound(vA, 1) To UBound(vA, 1)
vA(r, 1) = CLng(Mid$(sIn, r, 1))
Next r
' mark intended positions until right number of
' non-overlapping errors is clear
Do Until nCount = nReqNumErr
nCount = 0
DoEvents
' get a sample of row numbers in the working range
nSample = Int((nRange - 1 + 1) * Rnd + 1)
' error flag added to col 2 of intended row
vA(nSample, 2) = 1 ' 1 denotes intention
' run through array col 1
For c = LBound(vA, 1) To UBound(vA, 1)
' count all intention markers so far
If vA(c, 2) = 1 Then
nCount = nCount + 1
End If
Next c
Loop
' when num errors is right modify the ones flagged
For r = LBound(vA, 1) To UBound(vA, 1)
sAccum = sAccum & CStr(vA(r, 1) Xor vA(r, 2))
Next r
InsertBERRnd = sAccum
End Function
Sub ConvolutionalDecodeD(ByVal sIn As String, sOut As String, sOut2 As String, bAmbiguous As Boolean, nConfiguration As Long, vRet As Variant, vTint As Variant)
' works with rate 1/2 coder; one bit in leads to two bits out
' 3 register equivalent, constraint 3, generator polynomials are top = (1,1,1) and bottom = (1,1,0) for 7,6
' and (1,1,1) and (1,0,1) for 7,5, selected by parameter nConfiguration= 75 or 76.
' NOTES: All calculations of metrics and displays use Hamming distance in this version.
' In branch estimates the highest is always discarded.
' If branch metrics are equal, discard the bottom of the two incoming branches.
' Working for metrics assumes position at node with two incoming branches.
' Back track starts at last column's metric minimum then follows survivor paths
' back to state "a" time zero.
Dim aV() As String, vH As Variant, sWIn As String, sPrevStateAccumL As String, sPrevStateAccumU As String
Dim nStartR As Long, nStartC As Long, sEdgeBits As String, sInputBit As String
Dim r As Long, c As Long, nSwapR As Long, nSwapC As Long
Dim nVert As Long, nTime As Long, bUpperPath As Boolean, vW As Variant
Dim sAccumEdgeValues As String, sAccumImpliesBits As String
Dim sCurrState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, sLSOut As String
Dim sBitU As String, sBitL As String, sRcdBits As String, nNumTrans As Long
Dim sProposedAccumU As String, sProposedAccumL As String, sDiscardedU As String, sDiscardedL As String
Dim sNodeAccum As String, nNumLows As Long
' check that number received is even
sWIn = sIn
If Len(sWIn) Mod 2 = 0 Then
nNumTrans = Len(sWIn) / 2
Else
MsgBox "Odd bit pairing at input decoder -closing"
Exit Sub
End If
' dimension arrays
Erase aV()
ReDim aV(0 To nNumTrans, 1 To 4, 1 To 3) ' x transitions, y states, z node data
ReDim vH(1 To 4, 1 To 3) ' r states, c node data
ReDim vW(0 To nNumTrans, 1 To 4) ' r transitions, c states
ReDim vTint(0 To nNumTrans, 1 To 2) ' back path tint array
aV(0, 1, 3) = "0" ' set metric for zero node
' CYCLE LOOP
For nTime = 1 To nNumTrans
For nVert = 1 To 4
DoEvents
' Get incoming branch data for current node
If nConfiguration = 75 Then
GeneralDataT7B5 nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
ElseIf nConfiguration = 76 Then
GeneralDataT7B6 nVert, sCurrState, sPrevStateU, sPrevStateL, sUSOut, sLSOut, sBitU, sBitL
End If
' Get the received bits for the incoming transition
sRcdBits = Mid$(sWIn, (nTime * 2) - 1, 2)
' get the current node's previous states' metrics
If sCurrState = "a" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
If sCurrState = "a" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
If sCurrState = "b" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
If sCurrState = "b" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
If sCurrState = "c" And sPrevStateU = "a" Then sPrevStateAccumU = aV(nTime - 1, 1, 3)
If sCurrState = "c" And sPrevStateL = "b" Then sPrevStateAccumL = aV(nTime - 1, 2, 3)
If sCurrState = "d" And sPrevStateU = "c" Then sPrevStateAccumU = aV(nTime - 1, 3, 3)
If sCurrState = "d" And sPrevStateL = "d" Then sPrevStateAccumL = aV(nTime - 1, 4, 3)
' NOTE ON EXCEPTIONS
' Exceptions for transitions 0, 1 and 2. Some redundant, or fewer than two incoming branches.
' Nodes with single incoming branches; mark blind branches same edge value as existing edge,
' and mark their previous metrics as arbitrarily high. Because policy for choosing equal metrics is always
' to discard the bottom one, exceptions can then be handled in same loop.
' Zero column is handled entirely by settings for transition 1.
' Apply exceptions settings
If nConfiguration = 75 Then
FrontExceptions75D nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
ElseIf nConfiguration = 76 Then
FrontExceptions76D nTime, nVert, sLSOut, sUSOut, sPrevStateAccumL, sPrevStateAccumU
Else
MsgBox "Configuration not defined"
End If
' Calculate incoming branch metrics and add their previous path metrics to each
sProposedAccumU = CStr(GetProposedAccum(sRcdBits, sUSOut, sPrevStateAccumU))
sProposedAccumL = CStr(GetProposedAccum(sRcdBits, sLSOut, sPrevStateAccumL))
' Decide between the two proposed metrics for the current node
' Accept the higher value branch metric and discard the other
' If same in value, choose the top branch and discard the bottom.
If CLng(sProposedAccumU) > CLng(sProposedAccumL) Then
sDiscardedL = "Keep": sDiscardedU = "Discard"
sNodeAccum = sProposedAccumL
ElseIf CLng(sProposedAccumU) < CLng(sProposedAccumL) Then
sDiscardedL = "Discard": sDiscardedU = "Keep"
sNodeAccum = sProposedAccumU
ElseIf CLng(sProposedAccumU) = CLng(sProposedAccumL) Then
sDiscardedL = "Discard": sDiscardedU = "Keep"
sNodeAccum = sProposedAccumU
End If
' Update the node array with the discard data
aV(nTime, nVert, 1) = sDiscardedU ' whether or not upper incoming discarded
aV(nTime, nVert, 2) = sDiscardedL ' whether or not lower incoming discarded
' Update the node array with the value of path metric for the current node
aV(nTime, nVert, 3) = sNodeAccum ' update work array with metric
' Update return work array with node metric value for the sheet display
vW(nTime, nVert) = CLng(sNodeAccum) ' update return display array with metric
Next nVert
Next nTime
' Transfer last column metric values to a work array
c = nNumTrans ' the last column number
For r = 1 To 4 ' number of rows in every column
vH(r, 1) = CLng(aV(c, r, 3)) ' metrics
vH(r, 2) = CLng(c) ' column where metric found in main array
vH(r, 3) = CLng(r) ' row where metric found in main array
Next r
' Sort descending
SortMetricsArr2D1Key vH, 1, 1, 1 ' and assoc recs are in same row
' Detect start point ambiguity for possible future use
' Count number of entries with same low value in column
nNumLows = 0
For r = 1 To 4 ' number rows in every column
If vH(1, 1) = vH(r, 1) Then nNumLows = nNumLows + 1
Next r
If nNumLows > 1 Then bAmbiguous = True
' Note the row and column numbers for the back path start point
nStartR = CLng(vH(1, 3)) ' retrieve row number
nStartC = CLng(vH(1, 2)) ' retrieve col number
' add coordinates to vTint
vTint(nStartC, 1) = nStartR
vTint(nStartC, 2) = nStartC
' BACK PATH
' Navigate the back path and extract its data
Do Until nStartC <= 0
DoEvents ' allow system requests
' Find survivor path into this node
' if upperpath is open...
If aV(nStartC, nStartR, 1) = "Keep" Then bUpperPath = True Else bUpperPath = False
' if lower path is open...
If aV(nStartC, nStartR, 2) = "Keep" Then bUpperPath = False Else bUpperPath = True
' Get present state
sCurrState = GetStateFmRow(nStartR) ' common
' Use present state name to fetch the output bits
If nConfiguration = 75 Then
GetOutputBitsT7B5 sCurrState, bUpperPath, sEdgeBits, sInputBit
ElseIf nConfiguration = 76 Then
GetOutputBitsT7B6 sCurrState, bUpperPath, sEdgeBits, sInputBit
Else
MsgBox "Configuration not defined"
End If
' Accumulate output and input values for hop
sAccumEdgeValues = sEdgeBits & sAccumEdgeValues ' edge values -not used
sAccumImpliesBits = sInputBit & sAccumImpliesBits ' decoded message -used
' Get array coordinates for next node in back path
If nConfiguration = 75 Then
GetPosOfSourceT7B5 nStartR, nStartC, bUpperPath, nSwapR, nSwapC
ElseIf nConfiguration = 76 Then
GetPosOfSourceT7B6 nStartR, nStartC, bUpperPath, nSwapR, nSwapC
Else
MsgBox "Configuration not defined"
End If
' Update the new position coordinates for the next hop
nStartR = nSwapR
nStartC = nSwapC
' add coordinates to vTint
vTint(nStartC, 1) = nStartR
vTint(nStartC, 2) = nStartC
Loop
Transfers:
ReDim vRet(LBound(vW, 1) To UBound(vW, 1), LBound(vW, 2) To UBound(vW, 2))
vRet = vW
sOut = sAccumImpliesBits 'message single bit stream
sOut2 = sAccumEdgeValues 'back path edge double bit stream
End Sub
Function FrontExceptions75D(ByVal nT As Long, ByVal nV As Long, _
sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
' applies the exceptions for configuration 7,5 - applies to distance only
If nT = 1 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20": sPSAU = "0"
ElseIf nT = 1 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20": sPSAU = "0"
ElseIf nT = 2 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20"
ElseIf nT = 2 And nV = 2 Then
sLSO = "10": sUSO = "10": sPSAL = "20"
ElseIf nT = 2 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20"
ElseIf nT = 2 And nV = 4 Then
sLSO = "01": sUSO = "01": sPSAL = "20"
End If
FrontExceptions75D = True
End Function
Function FrontExceptions76D(ByVal nT As Long, ByVal nV As Long, _
sLSO As String, sUSO As String, sPSAL As String, sPSAU As String) As Boolean
' applies the exceptions for configuration 7,5 -applies to distance only
If nT = 1 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20": sPSAU = "0"
ElseIf nT = 1 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20": sPSAU = "0"
ElseIf nT = 2 And nV = 1 Then
sLSO = "00": sUSO = "00": sPSAL = "20" ' arbitrarily high
ElseIf nT = 2 And nV = 2 Then
sLSO = "11": sUSO = "11": sPSAL = "20"
ElseIf nT = 2 And nV = 3 Then
sLSO = "11": sUSO = "11": sPSAL = "20"
ElseIf nT = 2 And nV = 4 Then
sLSO = "00": sUSO = "00": sPSAL = "20"
End If
FrontExceptions76D = True
End Function
Function SortMetricsArr2D1Key(ByRef vA As Variant, _
Optional ByVal bIsAscending As Boolean = True, _
Optional ByVal bIsRowSort As Boolean = True, _
Optional ByVal SortIndex As Long = -1, _
Optional ByRef vRet As Variant) As Boolean
' --------------------------------------------------------------------------------
' Procedure : Sort2DArr
' Purpose : Bubblesorts a 2D array on 1 key, up or down, on any column or row.
' Options include in-place, with the source changed, or
' returned in vRet, with the source array intact.
' Optional parameters default to: ROW SORT in place, ASCENDING,
' using COLUMN ONE as the key.
' --------------------------------------------------------------------------------
Dim condition1 As Boolean, vR As Variant
Dim i As Long, j As Long, y As Long, t As Variant
Dim loR As Long, hiR As Long, loC As Long, hiC As Long
Dim bWasMissing As Boolean
' find bounds of vA data input array
loR = LBound(vA, 1): hiR = UBound(vA, 1)
loC = LBound(vA, 2): hiC = UBound(vA, 2)
' find whether optional vR was initially missing
bWasMissing = IsMissing(vRet)
' If Not bWasMissing Then Set vRet = Nothing
' check input range of SortIndex
If bIsRowSort And (SortIndex < loC Or SortIndex > hiC) Then
MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
Exit Function
Else:
End If
If Not bIsRowSort And (SortIndex < loR Or SortIndex > hiR) Then
MsgBox "SortIndex out of bounds in Sort2DArr; closing now"
Exit Function
Else:
End If
' pass to a work variable
vR = vA
' steer input options
If bIsRowSort Then GoTo ROWSORT Else GoTo COLSORT
ROWSORT:
For i = loR To hiR - 1
For j = loR To hiR - 1
If bIsAscending Then
condition1 = vR(j, SortIndex) > vR(j + 1, SortIndex)
Else
condition1 = vR(j, SortIndex) < vR(j + 1, SortIndex)
End If
If condition1 Then
For y = loC To hiC
t = vR(j, y)
vR(j, y) = vR(j + 1, y)
vR(j + 1, y) = t
Next y
End If
Next
Next
GoTo Transfers
COLSORT:
For i = loC To hiC - 1
For j = loC To hiC - 1
If bIsAscending Then
condition1 = vR(SortIndex, j) > vR(SortIndex, j + 1)
Else
condition1 = vR(SortIndex, j) < vR(SortIndex, j + 1)
End If
If condition1 Then
For y = loR To hiR
t = vR(y, j)
vR(y, j) = vR(y, j + 1)
vR(y, j + 1) = t
Next y
End If
Next
Next
GoTo Transfers
Transfers:
' decide whether to return in vA or vRet
If Not bWasMissing Then
' vRet was the intended return array
' so return vRet leaving vA intact
vRet = vR
Else:
' vRet is not intended return array
' so reload vA with vR
vA = vR
End If
' set return function value
SortMetricsArr2D1Key = True
End Function
Function GeneralDataT7B5(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
sLSOut As String, sBitU As String, sBitL As String) As Boolean
' takes as input nVert as position in trellis column and returns various data for that state
Select Case nVert
Case 1
sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "11": sBitU = "0": sBitL = "0"
Case 2
sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "10": sLSOut = "01": sBitU = "0": sBitL = "0"
Case 3
sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "00": sBitU = "1": sBitL = "1"
Case 4
sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "01": sLSOut = "10": sBitU = "1": sBitL = "1"
Case Else
End Select
GeneralDataT7B5 = True
End Function
Function GeneralDataT7B6(nVert As Long, sCState As String, sPrevStateU As String, sPrevStateL As String, sUSOut As String, _
sLSOut As String, sBitU As String, sBitL As String) As Boolean
' takes as input nVert as position in trellis column and returns various data for that state
Select Case nVert
Case 1
sCState = "a": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "00": sLSOut = "10": sBitU = "0": sBitL = "0"
Case 2
sCState = "b": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "11": sLSOut = "01": sBitU = "0": sBitL = "0"
Case 3
sCState = "c": sPrevStateU = "a": sPrevStateL = "b": sUSOut = "11": sLSOut = "01": sBitU = "1": sBitL = "1"
Case 4
sCState = "d": sPrevStateU = "c": sPrevStateL = "d": sUSOut = "00": sLSOut = "10": sBitU = "1": sBitL = "1"
Case Else
End Select
GeneralDataT7B6 = True
End Function
Function GetStateFmRow(nRow As Long) As String
' returns alpha name of state for parameter
' row position in trellis column
Select Case nRow
Case 1
GetStateFmRow = "a"
Case 2
GetStateFmRow = "b"
Case 3
GetStateFmRow = "c"
Case 4
GetStateFmRow = "d"
End Select
End Function
Function GetOutputBitsT7B6(sState As String, bUpper As Boolean, _
sEdgeBits As String, sInputBit As String) As Boolean
' returns edge value and input given the alpha state name
' and choice of top or bottom branch.
' Applies to incoming branches joining at the node.
Select Case sState
Case "a"
If bUpper = True Then
sEdgeBits = "00"
sInputBit = "0"
Else
sEdgeBits = "10"
sInputBit = "0"
End If
Case "b"
If bUpper = True Then
sEdgeBits = "11"
sInputBit = "0"
Else
sEdgeBits = "01"
sInputBit = "0"
End If
Case "c"
If bUpper = True Then
sEdgeBits = "11"
sInputBit = "1"
Else
sEdgeBits = "01"
sInputBit = "1"
End If
Case "d"
If bUpper = True Then
sEdgeBits = "00"
sInputBit = "1"
Else
sEdgeBits = "10"
sInputBit = "1"
End If
End Select
GetOutputBitsT7B6 = True
End Function
Function GetOutputBitsT7B5(sState As String, bUpper As Boolean, _
sEdgeBits As String, sInputBit As String) As Boolean
' returns edge value and input given the alpha state name
' and choice of top or bottom branch.
' Applies to incoming branches joining at the node.
Select Case sState
Case "a"
If bUpper = True Then
sEdgeBits = "00"
sInputBit = "0"
Else
sEdgeBits = "11"
sInputBit = "0"
End If
Case "b"
If bUpper = True Then
sEdgeBits = "10"
sInputBit = "0"
Else
sEdgeBits = "01"
sInputBit = "0"
End If
Case "c"
If bUpper = True Then
sEdgeBits = "11"
sInputBit = "1"
Else
sEdgeBits = "00"
sInputBit = "1"
End If
Case "d"
If bUpper = True Then
sEdgeBits = "01"
sInputBit = "1"
Else
sEdgeBits = "10"
sInputBit = "1"
End If
End Select
GetOutputBitsT7B5 = True
End Function
Function GetPosOfSourceT7B5(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
' returns the array column and row for an incoming branch,
' given its position in trellis column and choice of top or bottom branch.
Dim sNodesState As String
' convert to string state names
Select Case nNodeR
Case 1
sNodesState = "a"
Case 2
sNodesState = "b"
Case 3
sNodesState = "c"
Case 4
sNodesState = "d"
End Select
' for c=0 only
If nNodeC = 0 Then
MsgBox "No source beyond zero column"
Exit Function
End If
' For c>0 only
Select Case sNodesState
Case "a"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "b"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
Case "c"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "d"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
End Select
GetPosOfSourceT7B5 = True
End Function
Function GetPosOfSourceT7B6(nNodeR As Long, nNodeC As Long, bUpper As Boolean, _
nEdgeSourceR As Long, nEdgeSourceC As Long) As Boolean
' returns the array column and row for an incoming branch,
' given its position in trellis column and choice of top or bottom branch.
Dim sNodesState As String
' convert to string state names
Select Case nNodeR
Case 1
sNodesState = "a"
Case 2
sNodesState = "b"
Case 3
sNodesState = "c"
Case 4
sNodesState = "d"
End Select
' for c=0 only
If nNodeC = 0 Then
MsgBox "No source beyond zero column"
Exit Function
End If
' For c>0 only
Select Case sNodesState
Case "a"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "b"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
Case "c"
If bUpper = True Then
nEdgeSourceR = 1
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 2
nEdgeSourceC = nNodeC - 1
End If
Case "d"
If bUpper = True Then
nEdgeSourceR = 3
nEdgeSourceC = nNodeC - 1
Else
nEdgeSourceR = 4
nEdgeSourceC = nNodeC - 1
End If
End Select
GetPosOfSourceT7B6 = True
End Function
Function DigitsToSheetRow(ByVal sIn As String, ByVal nNumGrp As Long, _
ByVal nRow As Long, Optional ByVal sRLabel As String = "*")
' takes string of digits and an option code and distributes bits to worksheet rows
Dim n As Long, c As Long, sSamp As String
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets("Sheet1")
oSht.Activate
If Len(sIn) Mod nNumGrp <> 0 Then
MsgBox "Missing bits for grouping in DigitsToSheetRow - closing"
Exit Function
End If
c = 0
' 101 010 101 010
For n = 1 To (Len(sIn) - nNumGrp + 1) Step nNumGrp
DoEvents
sSamp = Mid$(sIn, n, nNumGrp)
c = c + 1
oSht.Cells(nRow, c + 1) = sSamp
If c >= 16384 Then Exit For
Next n
oSht.Cells(nRow, 1) = sRLabel
End Function
Sub ColourTheErrors(ByVal nLen As Long)
' colors specific data to show errors
' changes to decoder pairs in magenta
' changes between input and output message in red
' marks individual received bit errors in bold yellow
' marking is limited to 256 columns to accommodate Excel 2003
Dim oSht As Worksheet, c As Long, nRow As Long
Set oSht = ThisWorkbook.Worksheets("Sheet1")
oSht.Activate
With oSht.Cells
.Font.Color = RGB(0, 0, 0)
.Font.Bold = False
End With
'clear colours in rows below first four to preserve backpath
For nRow = 5 To 20
oSht.Rows(nRow).Cells.Interior.Pattern = xlNone
Next nRow
For c = 2 To nLen + 1 'this is specified length of the string for display
'Note that Excel versions have different max columns
'Up to user to get it right eg: max 256 for Excel 2003
'block with error colouring
'message errors are in red
If oSht.Cells(10, c) <> oSht.Cells(6, c) Then oSht.Cells(10, c).Interior.Color = vbRed
'received channel errors magenta
If oSht.Cells(7, c) <> oSht.Cells(8, c) Then oSht.Cells(8, c).Interior.Color = vbMagenta
'individual errored character colouring in yellow within magenta block
If Left(oSht.Cells(8, c).Value, 1) <> Left(oSht.Cells(7, c).Value, 1) Then
With oSht.Cells(8, c).Characters(1, 1).Font
.Color = -16711681
.Bold = True
End With
End If
If Right(oSht.Cells(8, c).Value, 1) <> Right(oSht.Cells(7, c).Value, 1) Then
With oSht.Cells(8, c).Characters(2, 1).Font
.Color = -16711681
.Bold = True
End With
End If
Next c
End Sub
Function AutoRandomInput(ByVal nLength As Long) As String
' makes a pseudo random string of parameter nLength
Dim n As Long, sSamp As String, sAccum As String
' Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Randomize Timer
For n = 1 To (nLength)
sSamp = CStr(Int((1 - 0 + 1) * Rnd + 0))
sAccum = sAccum & sSamp
Next n
AutoRandomInput = sAccum
End Function
Function GetProposedAccum(ByVal sIn1 As String, ByVal sIn2 As String, ByVal sPrevAccum As String) As Long
' Compares two binary strings of equal length
' Returns the count of the bits in function name plus sPrevAccum that are different
' It is the Hamming distance between the two binary bit strings plus some accum metric
Dim nErr As Long, n As Long, m As Long
' check that streams are same length for comparison
If Len(sIn1) <> Len(sIn2) Then
MsgBox "Stream lengths do not match in StrDifference - closing"
Exit Function
End If
' 0 and 0 = 0
' 0 and 1 = 1
' 1 and 0 = 1
' 1 and 1 = 0
For n = 1 To Len(sIn1)
nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1)))
m = m + nErr
Next n
Transfers:
If sPrevAccum = "" Then sPrevAccum = "0"
GetProposedAccum = m + CLng(sPrevAccum)
End Function
Function NumBitsDifferent(ByVal sIn1 As String, ByVal sIn2 As String, Optional nLength As Long) As Long
' compares two binary strings of equal length
' and returns the count of the bits in function name that are different
' It is the Hamming distance between the two binary bit strings
Dim nErr As Long, n As Long, m As Long
' check that streams are same length for comparison
If Len(sIn1) <> Len(sIn2) Then
MsgBox "Stream lengths do not match in StrDifference - closing"
Exit Function
End If
' 0 and 0 = 0
' 0 and 1 = 1
' 1 and 0 = 1
' 1 and 1 = 0
For n = 1 To Len(sIn1)
nErr = Abs(CLng(Mid$(sIn1, n, 1)) - CLng(Mid$(sIn2, n, 1)))
m = m + nErr
Next n
Transfers:
nLength = Len(sIn1)
NumBitsDifferent = m
End Function
See Also
- A Basic Convolutional Coding Example: Detailed working for an error correction configuration. Describes the subject material for which the simulator was made.
- Viterbi Simulator in VBA: To display metrics in terms of closeness instead of Hamming Distance as is the case on this page.
External Links
Generate Random Dictionary Words
Summary
This VBA code module works only in MS Word. It generates a pseudo random list of dictionary words, listing them in the immediate window of the VBA editor.
The VBA Code
- Copy the code listing into a standard VBA module in MS Word and save the file as a docm type. Set the user options in the top section and run the procedure to produce the list.
- The variable Num sets the number of words as output, and the variable TypoLen should be set to the approximate length of the sought-after words.
- There is no ready-made collection of English words called a Dictionary in MS Word; the term is used for sets of user-constructed word lists. To access a list of English words, an indirect method needs to be used. A random word is first generated equal in length to TypoLen. The spell checker then fails to recognize the word so generates suggestions, this time as a proper collection. Provided that there is at least one such suggestion in the spell check collection, a random choice is made from among them for the output list. The loop continues until the chosen number of words has been produced.
The Code Module
Sub GetNRandomWords()
'Prints N randomly selected words
'in the Immediate Window
'Works in MS WORD only
Dim Sugg As SpellingSuggestions
Dim TypoLen As Long, n As Long
Dim sMakeWord As String, nR As Long
Dim Num As Long, p As Long
'set user options
TypoLen = 7 'trial text length
Num = 10 'number of samples
Randomize
Do
p = p + 1
Do
DoEvents
sMakeWord = ""
'make a misspelled word of length TypoLen
For n = 1 To TypoLen
'concatenate random charas
sMakeWord = sMakeWord & Chr(Int(26 * Rnd + Asc("a")))
Next n
'get resulting spelling suggestions collection
Set Sugg = GetSpellingSuggestions(sMakeWord)
'random select a suggestion
If Sugg.Count >= 1 Then 'assuming there is at least one
'random select one suggestion
nR = Int((Sugg.Count - 1 + 1) * Rnd + 1)
Debug.Print Sugg(nR) 'OUTPUT
'MsgBox Sugg(nR)
End If
Loop Until Sugg.Count >= 1
Loop Until p >= Num
End Sub
See Also
External Links
Transfer Data to the Worksheet
Summary
This page gives an overview of transferring data from VBA to the worksheet. The code module includes procedures for transfer of both one and two dimensional arrays to the sheet. Brief code line notes are also included for single line and block transfers.
Contents of the Module
- The module works best if kept intact. The top procedure has code lines to run the other procedures. Just de-comment the code that you intend to run, and add comment marks to the lines that are not intended to run.
- The code procedures include normal or transposed transfers from two dimensional arrays.
- In addition, the handling of one dimensional arrays has been included. They can be transferred into a column or a row.
- The placement position can be specified in every case.
- Note that the selected worksheet will be cleared on each run, so select a worksheet for output that will not remove essential data.
- ConvColAlphaToNum() and ConvColNumToAlpha() are included to convert worksheet column references between the alpha and numeric formats.
- Additional procedures have been added for clearing and formatting text and the sheet.
The Code Module
Option Explicit
Sub TestArraysToSheet()
'test proc for transfers to the sheet
'de-comment lines to test the code
Dim vDim1 As Variant, vDim2 As Variant, vTemp As Variant, vR
Dim oSht As Worksheet, r As Long, c As Long, rTarget As Range
Dim Rng as range
' set choice of worksheet
Set oSht = ActiveWorkbook.Worksheets("Sheet2")
set rng=osht.cells(1,1)
' clear existing contents of worksheet
oSht.Activate
oSht.Cells.ClearContents
' load 1D test array
vDim1 = Array(9, 8, 7, 5, 6, 4, 3, 2, 1, 0) 'or,
'vDim1 = Array("Horses", "Dogs", "Zebras", "Fleas") 'or,
'vDim1 = Split("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", " ") 'zero based
' load 2D test array
ReDim vDim2(1 To 20, 1 To 10)
For r = 1 To 20
For c = 1 To 10
vDim2(r, c) = (r * c)
Next c
Next r
' CLEARING THE SHEET
'-------------------
oSht.Cells.ClearContents ' clears sheet text entries only
'oSht.Cells.ClearFormats ' clears sheet formats only
'oSht.Cells.Clear ' clears everthing on sheet
'oSht.Range("A1:G37").ClearContents 'clears entries from cell block
'oSht.Range(oSht.Cells(1, 1), oSht.Cells(1, 9)).ClearContents 'clears entries from cell block
'ClearRange rng, "contents" 'clears cell range according to option
'ClearWorksheet("Sheet2", 1 ) 'clears all sheet2 cell contents only
' REMOVE ALL WORKBOOK CHARTS
'---------------------------
'DeleteAllWorkbookCharts 'clears all charts from the workbook - not just those on top sheet
'' TRANSFER SINGLE VALUES TO SHEET
'--------------------------------
'oSht.Cells(3, 7).Value = "Totals" 'string to one specified cell
'oSht.Range("A1").Value = "Totals" 'string to one specified cell
' TRANSFER ONE VALUE TO A SHEET BLOCK
'------------------------------------
'oSht.Range(oSht.Cells(1, 1), oSht.Cells(10, 7)).Value = "N/A"
'oSht.Range("A1:F10").Value = "N/A"
'TRANSFER 1 DIMENSION LIST ARRAYS TO WORKSHEET
'---------------------------------------------
Array1DToSheetRow vDim1, "Sheet2", 3, 7 ' 1D array to sheet row, start position (3,7)
'Array1DToSheetCol vDim1, "Sheet2", 3, 7 ' 1D array to sheet column, start position (3,7)
'TRANSFER 2 DIMENSIONAL ARRAYS TO WORKSHEET
'------------------------------------------
'Array2DToSheet vDim2, "Sheet2", 2, 2 ' 2D array to sheet, start position (2,2)
'Arr1Dor2DtoWorksheet vDim2,"Sheet2",4,5 ' 1D or 2D array to worksheet; 2D here.
'TransArray2DToSheet vDim2, "Sheet2", 2, 2 ' TRANSPOSED 2D array to sheet, start position (2,2)
'TransposeArray2D vDim2, vTemp ' alternative method of TRANSPOSED 2D array to sheet
'Array2DToSheet vTemp,"Sheet2" , 1, 1
'FORMAT WORKSHEET CELLS AFTER TRANSFER
'------------------------------------------
'FormatCells "Sheet2" 'applies one of several formats to all cells of the worksheet
'FormatRange Rng, "bold" 'applies one of several formats to the specified cell range
End Sub
Sub Array1DToSheetCol(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of single dimension list array to specified position in worksheet
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nElem As Long
Dim nNewC As Long, nNewR As Long
' get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
' get the pre-shift end points
nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow + nElem - 1, nStartCol))
'transfer the array contents to the sheet range
rTarget.Value = Application.WorksheetFunction.Transpose(vIn)
End Sub
Sub Array1DToSheetRow(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of single dimension list array into a worksheet column
' The cell for the first element is set by nStartRow and nStartCol
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nElem As Long
Dim nNewC As Long, nNewR As Long
' get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
' get the pre-shift end points
nElem = UBound(vIn, 1) - LBound(vIn, 1) + 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nStartRow, nStartCol + nElem - 1))
'transfer the array contents to the sheet range
rTarget.Value = vIn
End Sub
Sub TransArray2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions TRANSPOSED
' The cell for the first element is set by nStartRow and nStartCol
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'swap cols and rows
nNewEndR = nCols + nStartRow - 1
nNewEndC = nRows + nStartCol - 1
' define the transposed range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = Application.WorksheetFunction.Transpose(vIn)
End Sub
Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
' transfers contents of input 2D array to specified worksheet positions
' Works for any array bounds
Dim oSht As Worksheet, rTarget As Range
Dim nRows As Long, nCols As Long
Dim nNewEndC As Long, nNewEndR As Long
'get reference to sheet for output
Set oSht = ActiveWorkbook.Worksheets(sShtName)
'get the pre-shift end points
nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
'modify end point for parameter starting values
nNewEndR = nRows + nStartRow - 1
nNewEndC = nCols + nStartCol - 1
' define the sheet range for the array contents
Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
'transfer the array contents to the sheet range
rTarget.Value = vIn
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
Function TransposeArray2D(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
TransposeArray2D = True
End Function
Sub testCellRefConversion()
'run this to cell reference conversions
Dim nNum As Long, sLet As String
'set input values here
nNum = 839
sLet = "AFG"
MsgBox ConvColAlphaToNum(sLet)
MsgBox ConvColNumToAlpha(nNum)
End Sub
Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
'Converts an Excel column reference from alpha to numeric
'For example, "A" to 1, "AFG" to 839 etc
Dim nColNum As Long
'get the column number
nColNum = Range(sColAlpha & 1).Column
'output to function
ConvColAlphaToNum = nColNum
End Function
Function ConvColNumToAlpha(ByVal nColNum As Long) As String
'Converts an Excel column reference from numeric to alpha
'For example, 1 to "A", 839 to "AFG" etc
Dim sColAlpha As String, vA As Variant
'get the column alpha, in form $D$14
sColAlpha = Cells(1, nColNum).Address
'split the alpha reference on $
vA = Split(sColAlpha, "$")
'output second element (1) of array to function
ConvColNumToAlpha = vA(1) 'array is zero based
End Function
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
Sub FormatCells(sSht As String)
' Applies certain formats to all cells
' of the named parameter sheet
Dim oSht As Worksheet
Set oSht = ThisWorkbook.Worksheets(sSht)
oSht.Activate
'format all cells of the worksheet
oSht.Cells.Select
With Selection
.Font.Name = "Consolas"
.Font.Size = 20
.Columns.AutoFit
.Rows.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
oSht.Range("A1").Select
End Sub
Sub testFormatRange()
'place some text in cell 1,1 of sheet1
Dim oSht As Worksheet, Rng As Range
Set oSht = ThisWorkbook.Worksheets("Sheet1")
Set Rng = oSht.Cells(1, 1)
FormatRange Rng, "autocols"
Rng.Select
Set Rng = Nothing
End Sub
Sub FormatRange(ByRef rRange As Range, ByVal sOpt As String)
' Applies certain formats to
' the parameter range of cells
' in accordance with selected option
With rRange
Select Case LCase(sOpt)
Case "consolas" 'make monospaced
.Font.Name = "Consolas"
Case "calibri" 'make non-mono
.Font.Name = "Calibri"
Case "autocols" 'autofit column width
.Columns.AutoFit
Case "noautocols" 'default column width
.ColumnWidth = 8.43
Case "hcenter" 'center text horizontally
.HorizontalAlignment = xlCenter
Case "hleft" 'left text horizontally
.HorizontalAlignment = xlLeft
Case "bold" 'bold text
.Font.Bold = True
Case "nobold" 'normal weight text
.Font.Bold = False
Case "italic" 'italic text
.Font.Italic = True
Case "noitalic" 'non-italic text
.Font.Italic = False
Case "underline" 'underlined text
.Font.Underline = xlUnderlineStyleSingle
Case "nounderline" 'non-underlined text
.Font.Underline = xlUnderlineStyleNone
Case Else
End Select
End With
End Sub
Sub testClearWorksheet()
'run this to test worksheet clearing
If SheetExists("Sheet1") Then
ClearWorksheet "Sheet11", 3
Else 'do other stuff
End If
End Sub
Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
'clears worksheet contents, formats, or both
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Function
End Select
End With
oWSht.Cells(1, 1).Select
ClearWorksheet = True
End Function
Sub testClearRange()
'place some text in cell 1,1 of sheet1
Dim oSht As Worksheet, Rng As Range
Set oSht = ThisWorkbook.Worksheets("Sheet1")
Set Rng = oSht.Cells(1, 1)
ClearRange Rng, "all"
Rng.Select
Set Rng = Nothing
End Sub
Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
'clears cell range contents, formats, or both
'sOpt options: "contents", "formats", or "all"
'sOpt is optional, default "contents".
With rRng
Select Case LCase(sOpt)
Case "contents" 'contents only
.ClearContents
Case "formats" 'formats only
.ClearFormats
Case "all" 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearRange - closing"
Exit Sub
End Select
End With
End Sub
See Also
External Links
Worksheet Common Utilities
Summary
The procedures on this page are made for Microsoft Excel, and include commonly used worksheet utilities.
The VBA Code
Modifications to Code
Does Worksheet Exist?
Before making a worksheet or referring to one that is assumed to exist, it is best to be certain one way or the other. This routine returns True if there is already a worksheet with the parameter's name.
Sub testSheetExists()
'run to test existence of a worksheet
If SheetExists("Sheet1") Then
MsgBox "Exists"
Else: MsgBox "Does not exist"
End If
End Sub
Function SheetExists(ByVal sSheetName As String) As Boolean
'Return true if sheet already exists
On Error Resume Next
'exists if its name is not the null string
SheetExists = (Sheets(sSheetName).Name <> vbNullString)
On Error GoTo 0
End Function
Add a Named Worksheet
This routine adds a worksheet with a specified name. First make sure however that the worksheet name is not in use; see SheetExists().
Sub testAddWorksheet()
AddWorksheet ("Sheet1")
End Sub
Function AddWorksheet(ByVal sName As String) As Boolean
'adds a Worksheet to ThisWorkbook with name sName
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sName
End With
AddWorksheet = True
End Function
Changing Column References
At times it is useful to have routines to change the column alpha reference style to a numerical one, and vice versa. These procedures to that.
Sub testCellRefConversion()
'run this to test cell reference conversions
Dim nNum As Long, sLet As String
'set input values here
nNum = 839
sLet = "AFG"
MsgBox ConvColAlphaToNum(sLet)
MsgBox ConvColNumToAlpha(nNum)
End Sub
Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
'Converts an Excel column reference from alpha to numeric
'For example, "A" to 1, "AFG" to 839 etc
Dim nColNum As Long
'get the column number
nColNum = Range(sColAlpha & 1).Column
'output to function
ConvColAlphaToNum = nColNum
End Function
Function ConvColNumToAlpha(ByVal nColNum As Long) As String
'Converts an Excel column reference from numeric to alpha
'For example, 1 to "A", 839 to "AFG" etc
Dim sColAlpha As String, vA As Variant
'get the column alpha, in form $D$14
sColAlpha = Cells(1, nColNum).Address
'split the alpha reference on $
vA = Split(sColAlpha, "$")
'output second element (1) of array to function
ConvColNumToAlpha = vA(1) 'array is zero based
End Function
Next Free Row or Column
These procedures find the next free column or row. One set selects the cell in question while the other set simply return its position. Examples exist for both columns and rows, and in the absence of a chosen parameter, column 1 or row 1 is assumed.
Sub testFindingNextCells()
'run this to test next-cell utilities
'Needs a few cols and rows of data in sheet1
'deselect to test
SelectNextAvailCellinCol 1
'MsgBox RowNumNextAvailCellinCol(1)
'SelectNextAvailCellinRow 6
'MsgBox ColNumNextAvailCellinRow(1)
End Sub
Function SelectNextAvailCellinCol(Optional ByVal nCol as Long = 1) As Boolean
'Selects next available blank cell
'in column nCol, when approached from sheet end
Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Select
End Function
Function RowNumNextAvailCellinCol(Optional ByVal nCol As Long = 1) As Long
'Returns next available blank cell's row number
'in column nCol, when approached from sheet end
RowNumNextAvailCellinCol = Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Row
End Function
Function SelectNextAvailCellinRow(Optional ByVal nRow as Long = 1) As Boolean
'Selects next available blank cell
'in row nRow, when approached from sheet right
Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Select
End Function
Function ColNumNextAvailCellinRow(Optional ByVal nRow As Long = 1) As Long
'Returns next available blank cell column number
'in row nRow, when approached from sheet right
ColNumNextAvailCellinRow = Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Column
End Function
Clear Worksheet Cells
This procedure makes a selective clear of the specified worksheet, depending on the parameter nOpt. The options as coded include, clear contents, (that is the text), clear formats, (the fonts and colours), and clear all, a combination of the two.
Sub testClearWorksheet()
'run this to test worksheet clearing
If SheetExists("Sheet1") Then
ClearWorksheet "Sheet11", 3
Else 'do other stuff
End If
End Sub
Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
'clears worksheet contents, formats, or both
'nOpt options: contents=1, formats=2, all=3
Dim oWSht As Worksheet
Set oWSht = ThisWorkbook.Worksheets(sSheet)
oWSht.Activate
With oWSht.Cells
Select Case nOpt
Case 1 'contents only
.ClearContents
Case 2 'formats only
.ClearFormats
Case 3 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearWorksheet - closing"
Exit Function
End Select
End With
oWSht.Cells(1, 1).Select
ClearWorksheet = True
End Function
Sub testClearRange()
'place some text in cell 1,1 of sheet1
Dim oSht As Worksheet, Rng As Range
Set oSht = ThisWorkbook.Worksheets("Sheet1")
Set Rng = oSht.Cells(1, 1)
ClearRange Rng, "all"
Rng.Select
Set Rng = Nothing
End Sub
Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
'clears cell range contents, formats, or both
'sOpt options: "contents", "formats", or "all"
'sOpt is optional, default "contents".
With rRng
Select Case LCase(sOpt)
Case "contents" 'contents only
.ClearContents
Case "formats" 'formats only
.ClearFormats
Case "all" 'formats and contents
.Clear
Case Else
MsgBox "Illegal option in ClearRange - closing"
Exit Sub
End Select
End With
End Sub
Move Rows and Columns
At times it is useful to shift entire columns and rows of data by one place on the spreadsheet, and in any case the process can be repeated as often as is necessary. These procedures assume that the user has first placed the cursor in the column or row of interest. The columns feature is of particular use when bringing an external tabulation into the worksheet; the columns will almost certainly need to be rearranged to match those of the resident set. Food databases are notorious for their different formats, none matching the sequence of those on food labels. Hopefully, some day a product's food data could be entered all at once with a scanned image.
Sub MoveRowDown()
'moves entire row with cursor down by one place
'works by moving next row up by one place
'includes all formats
Range(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Cut
ActiveCell.EntireRow.Insert xlShiftDown
ActiveCell.Offset(1, 0).Select
End Sub
Sub MoveRowUp()
'moves entire row with cursor up by one place
'includes all formats
If ActiveCell.Row > 1 Then
Range(ActiveCell.Row & ":" & ActiveCell.Row).Cut
ActiveCell.Offset(-1, 0).Select
ActiveCell.EntireRow.Insert xlShiftDown
Else
MsgBox "Already at top"
End If
End Sub
Sub MoveColLeft()
'moves entire column with cursor left one place
'includes all formats
Dim sColAlpha As String, vA As Variant
Dim sCol As String
If ActiveCell.Column > 1 Then
'get the alpha reference for the column
sColAlpha = Cells(1, ActiveCell.Column).Address
vA = Split(sColAlpha, "$")
sCol = vA(1) 'array zero based
'then do the cut and insert
Range(sCol & ":" & sCol).Cut
ActiveCell.Offset(0, -1).Select
ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
Else
MsgBox "Already at extreme left"
End If
End Sub
Sub MoveColRight()
'moves entire column with cursor right one place
'works by moving next column left one place
'includes all formats
Dim sColAlpha As String, vA As Variant
Dim sCol As String
'get the alpha reference for the next column right
sColAlpha = Cells(1, ActiveCell.Column + 1).Address
vA = Split(sColAlpha, "$")
sCol = vA(1) 'array zero based
'then do the cut and insert to left for next col
Range(sCol & ":" & sCol).Cut
ActiveCell.Select
ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
ActiveCell.Offset(0, 1).Select
End Sub
Delete Various Worksheet Items
These procedures allow deletion of worksheets, rows, and columns. Before deleting a worksheet, it should first be confirmed to exist.
Sub testDeleteItems()
'run to test item deletion
'MsgBox DeleteRow(6, "Sheet1")
'MsgBox DeleteCol(3, "Sheet1")
MsgBox DeleteSheet("Sheet4")
End Sub
Function DeleteSheet(ByVal nSht As String) As Boolean
'Returns true if nSht deleted else false
'Check first if sheet exists before running this
'No confirmation dialog will be produced
Application.DisplayAlerts = False 'avoids confirm box
DeleteSheet = ThisWorkbook.Worksheets(nSht).Delete
Application.DisplayAlerts = True
End Function
Function DeleteRow(ByVal nRow As Long, ByVal sSht As String) As Boolean
'Returns true if nRow deleted else false
'No confirmation dialog will be produced
DeleteRow = ThisWorkbook.Worksheets(sSht).Rows(nRow).Delete
End Function
Function DeleteCol(ByVal nCol As Long, ByVal sSht As String) As Boolean
'Returns true if nCol deleted else false
'No confirmation dialog will be produced
DeleteCol = ThisWorkbook.Worksheets(sSht).Columns(nCol).Delete
End Function
See Also
{bookcat}
VBA Code to Read ASCII Log Data from LAS File
Summary
This page lists a VBA Sub procedure to read data from a LAS file. A LAS file is an industry-standard binary format for storing airborne LIDAR data. Sub procedure requirements:
- A LAS file must be located in the same folder where the macro-enabled Excel file is located
- The active worksheet must have in cell A1 the name of the LAS file
VBA Code
Sub ReadProperties()
Dim numWords As Long
Dim stringLine As String, fileName As String, lineStringVector() As String, headerStart As String
Dim n As Long, i As Long, numLineHeader As Long, lenStringVector As Long, j As Long
Dim colStart As Long, numProp As Long
Dim rowStart As Long, rowNumCounter As Long, numDepths As Long
Dim StartDatProp As Range, dataArray(1 To 10000, 1 To 20) As Double
fileName = Cells(1, 1).Value
Cells(1, 2).Value = "Num Prop:": Cells(1, 4).Value = "Num Depths"
n = 0: rowStart = 2: colStart = 2: rowNumCounter = 1
Open fileName For Input As 1
Do While Not EOF(1)
Line Input #1, stringLine
headerStart = Left(stringLine, 2) ' stores in headerStart the first two characters of the string stringLine
If headerStart = "~A" Then
numLineHeader = n + 1
lineStringVector() = Split(Trim(stringLine), " ")
lenStringVector = UBound(lineStringVector) - LBound(lineStringVector) + 1
numWords = 0: j = 1
For i = 0 To lenStringVector - 1
If lineStringVector(i) <> "" Then
numWords = numWords + 1
Cells(rowStart, j).Value = lineStringVector(i)
j = j + 1
End If
Next i
numProp = numWords - 1
Cells(1, 3).Value = numProp
End If
If numLineHeader > 0 And n >= numLineHeader Then
lineStringVector() = Split(Trim(stringLine), " ")
lenStringVector = UBound(lineStringVector) - LBound(lineStringVector) + 1
j = 0
For i = 0 To lenStringVector - 1
If lineStringVector(i) <> "" Then
Cells(rowStart + rowNumCounter, colStart + j).Value = lineStringVector(i)
dataArray(rowNumCounter, j + 1) = lineStringVector(i)
j = j + 1
End If
Next i
rowNumCounter = rowNumCounter + 1
End If
n = n + 1
Loop
Close 1
numDepths = rowNumCounter - 1
Cells(1, 5).Value = numDepths
Cells(rowStart, 2).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.NumberFormat = "0.000"
Cells(rowStart, 2).Select
End Sub
Example Data to Test
You may create a ASCII file with extension LAS using the following example of data.
| Screenshot showing content of LAS file |
|---|
 |
Output on worksheet after running VBA Sub
| Screenshot showing Excel active worksheet after running VBA Sub |
|---|
 |
The book could not be loaded just now.