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.
Add a Reference Number to Outgoing Outlook Messages
A user in a VBA forum requested a process to add a reference number to the top of all outgoing messages, but was unclear about where the reference numbers were to be logged, so I thought it worth using Excel both to create the numbers and to record what messages they applied to.
The macro also creates the workbook if not already present and sets the start number of the first record to 1 (though you can change that to any number you wish)
For this to be a useful process it should happen transparently, so much of the work is done using ADO to access the workbook without opening it in Excel, which would prolong the process. Once the workbook is created and the first number applied, which takes a few moments, subsequent additions are imperceptible to the user.
The macro uses event processing to intercept the Send function and process the outgoing message, so the code should be added to the 'ThisOutlookSession' module of the Outlook VBA editor.
The code is annotated where appropriate and employs a number of my standard functions to establish whether files and folders exist and to create new ones as required.
The macro takes the message in the first illustration and adds the line of text in the second
The messages and their reference numbers are stored in the log:
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Graham Mayor 07 June 2015
'Macro goes in the 'ThisOutlookSession' module
'A process to add a reference number to the start of all outgoing messages and
'record the messages in an Excel log file.
'The name and path of the log
Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data
'The folder in which the log is saved.
Const strPath As String = "C:\MessageLog\" 'The folder to store the data
'The Excel fields used to record the data
Const strFields As String = "RefNo|Date|Time|MessageTo|Subject" 'The fields to store the data
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strValues As String
Dim iStartNum As Long
Dim strSubject As String
Dim strDate As String
Dim strTime As String
Dim strRecipient As String
'Establish whether the folder exists and if not create it.
If Not FileExists(strWorkbook) Then
CreateFolders strPath
xlCreateBook strWorkbook, strFields
'It's a new file so start the numbering for the first record
iStartNum = 0 ' One less than the first number to record.
Else
'It's an existing log so get the last used reference number
iStartNum = xlGetLastNum(strWorkbook)
End If
'Set the data and time formats
strDate = Format(Date, "dd/MM/yyyy")
strTime = Format(Time, "HH:MM:SS")
'Process the outgoing message
With Item
strSubject = .Subject
strRecipient = Replace(.To, "'", "")
'Access the message body
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
'Set a range to the start of the message body
Set oRng = wdDoc.Range(0, 0)
'And add the date, time and add one to the last used reference number
oRng.Text = "Date: " & strDate & _
", Time: " & strTime & _
", Our Ref: " & _
CStr(iStartNum + 1) & vbCr & vbCr
'Record the values added to a string
strValues = CStr(iStartNum + 1) & "', '" & _
strDate & "', '" & _
strTime & "', '" & _
strRecipient & "', '" & _
strSubject
'Save the message
.Save
'Use ADO to write the values to the Excel log
WriteToWorksheet strWorkbook, "Sheet1", strValues
End With
lbl_Exit:
'Clean up
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
'Graham Mayor
'A Process to write the data to a workbook without opening it in Excel
'strWorkbook is the fullname of the workbook to process
'strRange is the name of the worksheet
'strValues is a list of the values separated by "', '"
Dim CN As Object
Dim ConnectionString As String
Dim strSQL As String
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Private Function xlGetLastNum(strWorkbook As String) As Long
'Graham Mayor
'A Process to read the last used number from the workbook without opening
'it in Excel
'strWorkbook is the fullname of the workbook to process
Dim RS As Object
Dim CN As Object
Const strWorksheetName As String = "Sheet1$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
With RS
.MoveLast
xlGetLastNum = .Fields(0)
End With
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
'Graham Mayor
'Create a new workbook with the required fields for the process
'strWorkbook is the fullname of the new workbook
'strTitles is a list of the field names separated by the '|' (pipe) symbol
Dim vValues As Variant
Dim xlApp As Object
Dim xlWB As Object
Dim bStarted As Boolean
Dim i As Long
vValues = Split(strTitles, "|")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
For i = 0 To UBound(vValues)
.Cells(1, i + 1) = vValues(i)
Next i
End With
xlWB.SaveAs strWorkbook
xlWB.Close 1
If bStarted Then
xlApp.Quit
Set xlApp = Nothing
Set xlWB = Nothing
End If
lbl_Exit:
Exit Sub
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor
'A function to create a named path if it doesn't exist
'strPath is the folder to check and/or create
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor
'A function to create unique filenames (works in all Office apps that run VBA)
'strPath is the folder in which the file will be saved e.g. C:\Path\
'strFileName is the original name of the file to be saved
'strExtension is the filename extension e.g. "xlsx", "docx" etc
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
'Graham Mayor
'A function to establish if a file exists
'(works in all Office apps that run VBA)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'A function to establish if a folder exists
'(works in all Office apps that run VBA)
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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Graham Mayor 07 June 2015
'Macro goes in the 'ThisOutlookSession' module
'A process to add a reference number to the start of all outgoing messages and
'record the messages in an Excel log file.
'The name and path of the log
Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data
'The folder in which the log is saved.
Const strPath As String = "C:\MessageLog\" 'The folder to store the data
'The Excel fields used to record the data
Const strFields As String = "RefNo|Date|Time|MessageTo|Subject" 'The fields to store the data
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strValues As String
Dim iStartNum As Long
Dim strSubject As String
Dim strDate As String
Dim strTime As String
Dim strRecipient As String
'Establish whether the folder exists and if not create it.
If Not FileExists(strWorkbook) Then
CreateFolders strPath
xlCreateBook strWorkbook, strFields
'It's a new file so start the numbering for the first record
iStartNum = 0 ' One less than the first number to record.
Else
'It's an existing log so get the last used reference number
iStartNum = xlGetLastNum(strWorkbook)
End If
'Set the data and time formats
strDate = Format(Date, "dd/MM/yyyy")
strTime = Format(Time, "HH:MM:SS")
'Process the outgoing message
With Item
strSubject = .Subject
strRecipient = Replace(.To, "'", "")
'Access the message body
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
'Set a range to the start of the message body
Set oRng = wdDoc.Range(0, 0)
'And add the date, time and add one to the last used reference number
oRng.Text = "Date: " & strDate & _
", Time: " & strTime & _
", Our Ref: " & _
CStr(iStartNum + 1) & vbCr & vbCr
'Record the values added to a string
strValues = CStr(iStartNum + 1) & "', '" & _
strDate & "', '" & _
strTime & "', '" & _
strRecipient & "', '" & _
strSubject
'Save the message
.Save
'Use ADO to write the values to the Excel log
WriteToWorksheet strWorkbook, "Sheet1", strValues
End With
lbl_Exit:
'Clean up
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
'Graham Mayor
'A Process to write the data to a workbook without opening it in Excel
'strWorkbook is the fullname of the workbook to process
'strRange is the name of the worksheet
'strValues is a list of the values separated by "', '"
Dim CN As Object
Dim ConnectionString As String
Dim strSQL As String
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Private Function xlGetLastNum(strWorkbook As String) As Long
'Graham Mayor
'A Process to read the last used number from the workbook without opening
'it in Excel
'strWorkbook is the fullname of the workbook to process
Dim RS As Object
Dim CN As Object
Const strWorksheetName As String = "Sheet1$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
With RS
.MoveLast
xlGetLastNum = .Fields(0)
End With
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
'Graham Mayor
'Create a new workbook with the required fields for the process
'strWorkbook is the fullname of the new workbook
'strTitles is a list of the field names separated by the '|' (pipe) symbol
Dim vValues As Variant
Dim xlApp As Object
Dim xlWB As Object
Dim bStarted As Boolean
Dim i As Long
vValues = Split(strTitles, "|")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
For i = 0 To UBound(vValues)
.Cells(1, i + 1) = vValues(i)
Next i
End With
xlWB.SaveAs strWorkbook
xlWB.Close 1
If bStarted Then
xlApp.Quit
Set xlApp = Nothing
Set xlWB = Nothing
End If
lbl_Exit:
Exit Sub
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor
'A function to create a named path if it doesn't exist
'strPath is the folder to check and/or create
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor
'A function to create unique filenames (works in all Office apps that run VBA)
'strPath is the folder in which the file will be saved e.g. C:\Path\
'strFileName is the original name of the file to be saved
'strExtension is the filename extension e.g. "xlsx", "docx" etc
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
'Graham Mayor
'A function to establish if a file exists
'(works in all Office apps that run VBA)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'A function to establish if a folder exists
'(works in all Office apps that run VBA)
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
Outlook VBA
A VBA Code example for adding reference numbers (and dates) to outgoing Outlook messages.