Graham Mayor

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

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

 

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

 

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
Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strBMName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strBMName
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. The function calls the FileExists function (listed earlier) to establish that the image exists before attempting to insert it.

Public Sub ImageToBM(strBMName As String, strImagePath As String)
'Graham Mayor
Dim oRng As Range
If Not FileExists(strImagePath) Then GoTo lbl_Exit
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strBMName).Range
oRng.InlineShapes.AddPicture _
Filename:=strImagePath, LinkToFile:=False, _
SaveWithDocument:=True
oRng.End = oRng.End + 2
oRng.Bookmarks.Add strBMName
End With
lbl_Exit:
Set oRng = Nothing
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

 

 

Macros list

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