Useful VBA Functions

Many people access the material from this web site daily. Most just take what they want and run. That's OK, provided they are not selling on the material as their own; however if your productivity gains from the material you have used, a donation from the money you have saved would help to ensure the continued availability of this resource. Click the appropriate button above to access PayPal.

VBA - Useful functions to add to your projects

Like most programmers, I have a selection of functions that I use in a variety of projects. I thought I would share some of the must widely applicable examples:

Browse for File

One of the most frequent requirements is to browse for a file. The following function will return the name and path of the selected file:

Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
'Graham Mayor
'strTitle is the title of the dialog box
'Set bExcel value to True to filter the dialog to show Excel files
'The default is to show Word files
Dim fDialog As FileDialog
On Error GoTo err_handler
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.Filters.Clear
If bExcel Then
.Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
Else
.Filters.Add "Word documents", "*.doc,*.docx,*.docm"
End If
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_handler:
BrowseForFile = fDialog.SelectedItems.Item(1)
End With
lbl_Exit:
Exit Function
err_handler:
BrowseForFile = vbNullString
Resume lbl_Exit
End Function

File Exists?

Public Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function

FolderExists?

A companion function to the previous function, checks is a named folder exists.

Public Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'strFolderName is the name of folder to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Remove illegal filename characters from a string

Ensure that strings used for filenames do not include characters that are unacceptable in a filename. The filename under test may include the extension and the returned filename will include the extension.

Public Function CleanFileName(strFileName As String, strExtension As String) As String
'Graham Mayor
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
'strFilename is the filename to check
'strExtension is the extension of the file
Dim arrInvalid() As String
Dim vfName As Variant
Dim lng_Name As Long
Dim lng_Ext As Long
Dim lngIndex As Long
'Ensure there is no period included with the extension
strExtension = Replace(strExtension, Chr(46), "")
'Record the length of the extension
lng_Ext = Len(strExtension)

'Remove the path from the filename if present
If InStr(1, strFileName, Chr(92)) > 0 Then
vfName = Split(strFileName, Chr(92))
CleanFileName = vfName(UBound(vfName))
Else
CleanFileName = strFileName
End If

'Remove the extension from the filename if present
If Right(CleanFileName, lng_Ext + 1) = "." & strExtension Then
CleanFileName = Left(CleanFileName, InStrRev(CleanFileName, Chr(46)) - 1)
End If

'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Add the extension to the filename
CleanFileName = CleanFileName & Chr(46) & strExtension
'Remove any illegal filename characters
For lngIndex = 0 To UBound(arrInvalid)
CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95))
Next lngIndex
lbl_Exit:
Exit Function
End Function

FilenameUnique

Ensure existing filenames are not overwritten. If a proposed filename is found to exist in the target folder, then add an incrementing number to the proposed name until a uniquely numbered name is found.

Public Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor
'Requires the use of the FileExists function
'strPath is the path in which the file is to be saved
'strFileName is the filename to check
'strExtension is the extension of the filename to check
Dim lngF As Long
Dim lngName As Long
strExtension = Replace(strExtension, Chr(46), "")
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
'If the filename exists, add or increment a number to the filename
'and keep checking until a unique name is found
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
'Reassemble the filename
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

FolderNameUnique

Ensure existing folder names are not overwritten. If a proposed folder name is found to exist in the target folder, then add an incrementing number to the proposed name until a uniquely numbered name is found.

Public Function FolderNameUnique(strPath As String) As String
'Graham Mayor
'Requires the use of the FolderExists function
'strPath is the path to evaluate
Dim lngF As Long
Dim lngName As Long
Dim strPathName As String
Dim bSlash As Boolean
If Right(strPath, 1) = Chr(92) Then
strPath = Left(strPath, Len(strPath) - 1)
bSlash = True
End If
lngF = 1
strPathName = strPath
Do While FolderExists(strPath) = True
strPath = strPathName & "(" & lngF & ")"
lngF = lngF + 1
Loop
'Optionally re-add '\' to the end of the path
If bSlash = True Then strPath = strPath & Chr(92)
FolderNameUnique = strPath
lbl_Exit:
Exit Function
End Function

Create Folders

Create a named path if any part of that path (apart from the drive letter) is missing. The process will also create UNC network folder paths.

Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lngPathSep As Long
Dim lngPS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lngPathSep = InStr(3, strPath, "\")
If lngPathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
If lngPathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lngPathSep = 0
If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
oFSO.CreateFolder Left(strPath, lngPathSep)
End If
lngPS = lngPathSep
lngPathSep = InStr(lngPS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub

UpdateTemplate

Where the template running the code is used to store variables relating to the process, and those variables are changed by the code, the template will when closed prompt to be saved. The following function will save the template following any change precluding the requirement for the user to decide whether to save the template. The save is not recorded in the recent files list.

Public Sub UpdateTemplate()
'Graham Mayor
Dim bBackup As Boolean
bBackup = Options.CreateBackup
Options.CreateBackup = False
ThisDocument.Save
Options.CreateBackup = bBackup
lbl_Exit:
Exit Sub
End Sub

Extract the numeric part(s) of a text string

A function to extract the numeric parts only of a text string e.g. '123ABC' will result in '123' and '123ABC789' will produce '123789'

Public Function ExtractDigits(strText As String) As String
'Graham Mayor
Dim i As Integer
ExtractDigits = ""
For i = 1 To Len(strText)
If Mid(strText, i, 1) >= "0" And _
Mid(strText, i, 1) <= "9" Then
ExtractDigits = ExtractDigits + Mid(strText, i, 1)
End If
Next
lbl_Exit:
Exit Function
End Function

CountCharacters

A function to count the number of times a text character appears in a string

Public Function CountCharacters(strText As String, strChr As String, Optional bIgnoreCase As Boolean) As Integer
'Count the number of characters (strChr) in a string (strText), with the option to ignore the case of the character
If bIgnoreCase = True Then
CountCharacters = UBound(Split(LCase(strText), LCase(strChr)))
Else
CountCharacters = UBound(Split(strText, strChr))
End If
lbl_Exit:
Exit Function
End Function

GetEmailAddress

A function to extract the first e-mail address from a text string. If there is no e-mail address in the string, the function returns a null value.

Note: This function uses the presence of the @ symbol in a string to determine if there is an e-mail address (which always contains such a symbol) in the string. Where there are @ characters in the string before the first e-mail address that are not parts of an e-mail address, the process will attempt to eliminate them from consideration.

Function GetEmailAddress(ByVal strText As String) As String
Dim lng_Char As Long, lng_AtSign As Long
Const strLocale As String = "[A-Za-z0-9.!#$%&*/=?^_`{|}~+-]"
Const strDomain As String = "[A-Za-z0-9._-]"

If UBound(Split(strText, "@")) = 0 Then
GetEmailAddress = ""
GoTo lbl_Exit
End If

strText = Replace(strText, Chr(13), " ")
strText = Replace(strText, Chr(11), " ")
strText = Replace(strText, Chr(10), " ")
strText = Replace(strText, Chr(9), " ")

If UBound(Split(strText, "@")) > 1 Then
For lng_Char = 0 To UBound(Split(strText, "@"))
If InStr(1, strText, " @") > 0 Then
lng_AtSign = InStr(1, strText, " @")
ElseIf InStr(1, strText, "@ ") > 0 Then
lng_AtSign = InStr(1, strText, "@ ")
End If
If lng_AtSign > 0 Then
strText = Mid(strText, lng_AtSign + 1)
End If
Next lng_Char
End If

lng_AtSign = InStr(strText, "@")
For lng_Char = lng_AtSign To 1 Step -1
If Not Mid(" " & strText, lng_Char, 1) Like strLocale Then
strText = Mid(strText, lng_Char)
If Left(strText, 1) = "." Then strText = Mid(strText, 2)
Exit For
End If
Next lng_Char
lng_AtSign = InStr(strText, "@")
For lng_Char = lng_AtSign + 1 To Len(strText) + 1
If Not Mid(strText & " ", lng_Char, 1) Like strDomain Then
strText = Left(strText, lng_Char - 1)
If Right(strText, 1) = "." Then strText = Left(strText, Len(strText) - 1)
GetEmailAddress = strText
Exit For
End If
Next lng_Char
lbl_Exit:
Exit Function
End Function

FillBM

A function that takes all the thinking about writing values to bookmarks in a document. If the bookmark named does not exist the function does nothing. If it does the named value is written to the bookmarked location and the bookmark re-drawn to encompass the new value.

Public Sub FillBM(strbmName As String, strValue As String)
'Graham Mayor - https://www.gmayor.com - Last updated - 09 Aug 2020
Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
If .Bookmarks.Exists(strbmName) = True Then
Set oRng = .Bookmarks(strbmName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strbmName
End If
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub

ImageToBM

Whereas the previous function will write text to a bookmarked location, the following will insert a named image, the full path of which is entered into strImagePath.

Public Sub ImageToBM(strbmName As String, strImagePath As String)
'Graham Mayor - https://www.gmayor.com - Last updated - 09 Aug 2020
Dim oRng As Range
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strImagePath) Then
With ActiveDocument
On Error GoTo lbl_Exit
If .Bookmarks.Exists(strbmName) = True Then
Set oRng = .Bookmarks(strbmName).Range
oRng.Text = ""
oRng.InlineShapes.AddPicture _
FileName:=strImagePath, LinkToFile:=False, _
SaveWithDocument:=True
oRng.End = oRng.End + 1
oRng.Bookmarks.Add strbmName
End If
End With
End If
lbl_Exit:
Set FSO = Nothing
Set oRng = Nothing
Exit Sub
End Sub

AutoTextToBookmark

Insert a named autotext entry into a bookmarked location:

Sub AutoTextToBM(strbmName As String, oTemplate As Template, strAutotext As String)
'Graham Mayor - https://www.gmayor.com - Last updated - 09 Aug 2020
'strBMName is the name of the bookmark to fill
'oTemplate is the template with the autotext - probably ActiveDocument.AttachedTemplate
'strAutotext is the name of the autotext entry
Dim oRng As Range
On Error GoTo lbl_Exit
With ActiveDocument
If .Bookmarks.Exists(strbmName) = True Then
Set oRng = .Bookmarks(strbmName).Range
Set oRng = oTemplate.AutoTextEntries(strAutotext).Insert _
(Where:=oRng, RichText:=True)
.Bookmarks.Add Name:=strbmName, Range:=oRng
End If
End With
lbl_Exit:
Exit Sub
End Sub

IsInteger?

A function to check is an entered digit is a number between 0 and 9 and optionally a decimal point (change 46 to your regional decimal character ascii value:

Private Function IsInteger(ByVal i As String) As Boolean
'Graham Mayor
Select Case i
Case 48 To 57 'no decimals
'Case 46, 48 To 57 'include period character Chr(46) as a decimal
IsInteger = True
Case Else
IsInteger = False
End Select
lbl_Exit:
Exit Function
End Function

Validate Userform TextBox input for number entry

Sometimes you may wish to ensure that numbers entered into a userform text box are numeric. The following sub is associated with the text box in question and employs the previous function to validate the entry.

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Graham Mayor
'TextBox1 is the name of the text box to validate
Dim bTest As Boolean
bTest = IsInteger(KeyAscii) 'Test for integer
If bTest = False Then 'Action taken for non-integer
Beep
KeyAscii = 0
End If
lbl_Exit:
Exit Sub
End Sub

Page 1

Insert Field formatting switch
Number documents
Paste unformatted text
Copy footnotes c/w formatting to a new document
Send the current document from Word by e-mail as an attachment, with the header details pre-completed, e.g. for the return of a completed form document.
Toggle the SQL security entry in the registry through vba

Page 2

True title case
Extract acronyms to a new document
Format part of a found text string
Format part of a found text string in a list of items
Add a row to a table in a protected form
An alternative method of adding a row to a protected table

Page 3

Create a bar chart based on the content of a dropdown form field
Repeat a block of formatted text and form fields based upon the content of another form field
Colour a form field check box with a contrasting colour when it is checked.
Count times entered into a document
Transpose Characters
Insert Autotext Entry with VBA
Insert Building Blocks with VBA

Page 4

Replace a list of words from an array
Replace a list of words from a table
Replace a list of words from a table and offer a choice of replacements
Add tabs to centre of text area and right margin
Extract e-mail addresses from a document to a list
Fix scrambled view of some open type fonts in Word 2010
Word 2010 Print Preview

This Page

BrowseforFile
Browse for Folder
FileExists
FolderExists
CleanFileName
FileNameUnique
FolderNameUnique
CreateFolders
UpdateTemplate
ExtractDigits - from text string
FillBM
ImageToBM
IsInteger
Validate Userform TextBox

Graham Mayor

... helping to ease the lives of Microsoft Word users.

You appear to be using ad blocking software. While I respect your right to do so, please be aware that the minimal advertising on this site helps defray the cost of providing this facility, and I would therefore ask that you turn off the blocker while browsing this site.