I Need to have date and auto reference number on the top of the Body in all my outgoing emails.
I am using Outlook 2013.
Sorry for any mistake ( Not English my language )
I will appreciate very much any help.
I Need to have date and auto reference number on the top of the Body in all my outgoing emails.
I am using Outlook 2013.
Sorry for any mistake ( Not English my language )
I will appreciate very much any help.
Last edited by mike1881; 06-07-2015 at 07:42 AM.
Καλημέρα Mike
You didn't say 'where' you wanted the reference number, or where it was to be placed. The following assumes it will go after the subject and stores both the message detail and the incrementing number in an Excel worksheet 'C:\MessageLog\MessageLog.xls', which it will create (including the folder) if not present.
Put the code in Outlook's ThisOutlookSession module.
When you send a message, the next number will be added to the subject automatically, and details of the message stored.
Option Explicit Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data Const strPath As String = "C:\MessageLog\" 'The folder to store the data Const strFields As String = "RefNo|Date|Time|MessageTo|Subject" 'The fields to store the data Dim strValues As String Dim iStartNum As Long Dim strSubject As String Dim strDate As String Dim strTime As String Dim strRecipient As String If Not FileExists(strWorkbook) Then CreateFolders strPath xlCreateBook strWorkbook, strFields iStartNum = 0 ' One less than the first number to record. Else iStartNum = xlGetNextNum(strWorkbook) End If strSubject = Item.Subject strRecipient = Item.To strDate = Format(Date, "dd/MM/yyyy") strTime = Format(Time, "HH:MM") 'Write the value of iStartNum + 1 wherever you want it - here at the end of the subject. Item.Subject = strSubject & " - Ref: " & CStr(iStartNum + 1) strValues = CStr(iStartNum + 1) & "', '" & _ strDate & "', '" & _ strTime & "', '" & _ strRecipient & "', '" & _ strSubject Item.Save WriteToWorksheet strWorkbook, "Sheet1", strValues lbl_Exit: Exit Sub End Sub Private Function WriteToWorksheet(strWorkbook As String, _ strRange As String, _ strValues As String) 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 xlGetNextNum(strWorkbook As String) As Long 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 xlGetNextNum = .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) 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 FileExists(filespec) As Boolean 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(fldr) As Boolean Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If (fso.FolderExists(fldr)) Then FolderExists = True Else FolderExists = False End If lbl_Exit: Exit Function End Function Private Function CreateFolders(strPath As String) 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
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
Καλημέρα
Thank you very much for your message !
I want if of course its possible to be inserted on the begining of the email body,
something like << Date: 05/06/2015, Time: 12:37:05, Our Ref: 043359 >>
For example in this message to apear just before of Καλημερα
Thanks again.
Mike from Athens
OK that requires a small change to the main macro. The other functions remain as before:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data Const strPath As String = "C:\MessageLog\" 'The folder to store 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 If Not FileExists(strWorkbook) Then CreateFolders strPath xlCreateBook strWorkbook, strFields iStartNum = 43358 ' One less than the first number to record. Else iStartNum = xlGetNextNum(strWorkbook) End If strDate = Format(Date, "dd/MM/yyyy") strTime = Format(Time, "HH:MM:SS") With Item strSubject = .Subject strRecipient = .To Set olInsp = .GetInspector Set wdDoc = olInsp.WordEditor Set oRng = wdDoc.Range(0, 0) oRng.Text = "Date: " & strDate & _ ", Time: " & strTime & _ ", Our Ref: " & _ CStr(iStartNum + 1) & vbCr & vbCr strValues = CStr(iStartNum + 1) & "', '" & _ strDate & "', '" & _ strTime & "', '" & _ strRecipient & "', '" & _ strSubject .Save WriteToWorksheet strWorkbook, "Sheet1", strValues End With lbl_Exit: Set olInsp = Nothing Set wdDoc = Nothing Set oRng = Nothing Exit Sub End Sub
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
Hi Graham
In my profile of outlook i have some different accounts ( 4)
I am wondering if the code you gave me ( which works perfect ) can be work only for one profile ?
Thank you for your help.
Mike
If I understand correctly, you can use the same code in each profile.
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
Hi Graham.
Thank you for your reply.
Sorry i didn't explain well.
When i open Outlook loading 5 different email accounts, but i want only in one to use the VBA code.
Regards
Mike
If you want to limit the code to sending from just one account then add a condition to detect the account:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data
Const strPath As String = "C:\MessageLog\" 'The folder to store 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
If Item.SendUsingAccount.DisplayName = "sending account" Then ' the name of the account to restrict to
If Not FileExists(strWorkbook) Then
CreateFolders strPath
xlCreateBook strWorkbook, strFields
iStartNum = 43358 ' One less than the first number to record.
Else
iStartNum = xlGetNextNum(strWorkbook)
End If
strDate = Format(Date, "dd/MM/yyyy")
strTime = Format(Time, "HH:MM:SS")
With Item
strSubject = .Subject
strRecipient = .To
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = "Date: " & strDate & _
", Time: " & strTime & _
", Our Ref: " & _
CStr(iStartNum + 1) & vbCr & vbCr
strValues = CStr(iStartNum + 1) & "', '" & _
strDate & "', '" & _
strTime & "', '" & _
strRecipient & "', '" & _
strSubject
.Save
WriteToWorksheet strWorkbook, "Sheet1", strValues
End With
End If
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
Dear graham
thank you very much.
Dear Graham
As you understand i dont know almost nothing about VBA .
the code you previous sent me and works perfect is this >>
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Const strWorkbook As String = "C:\MessageLog\MessageLog.xlsx" 'The workbook to store the data
Const strPath As String = "C:\MessageLog\" 'The folder to store the data
Const strFields As String = "Reference No|Date|Time|MessageTo|Subject" 'The fields to store the data
Dim strValues As String
Dim iStartNum As Long
Dim strSubject As String
Dim strDate As String
Dim strTime As String
Dim strRecipient As String
If Not FileExists(strWorkbook) Then
CreateFolders strPath
xlCreateBook strWorkbook, strFields
iStartNum = 156 ' One less than the first number to record.
Else
iStartNum = xlGetNextNum(strWorkbook)
End If
strSubject = Item.Subject
strRecipient = Item.To
strDate = Format(Date, "dd/MM/yyyy")
strTime = Format(Time, "HH:MM")
'Write the value of iStartNum + 1 wherever you want it - here at the end of the subject.
Item.Subject = strSubject & " - Ref.: " & CStr(iStartNum + 153)
strValues = CStr(iStartNum + 1) & "', '" & _
strDate & "', '" & _
strTime & "', '" & _
strRecipient & "', '" & _
strSubject
Item.Save
WriteToWorksheet strWorkbook, "Sheet1", strValues
lbl_Exit:
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
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 xlGetNextNum(strWorkbook As String) As Long
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
xlGetNextNum = .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)
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 FileExists(filespec) As Boolean
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(fldr) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function CreateFolders(strPath As String)
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
i want to allow VBA to add Ref Nr only when i sending from the account miky, But not if i sending message from account michael .
Can you please add these to codes because i get error message ?
Thank you again very much.
Michael
Did you add the two bold lines to the macro as indicated? Did you change 'Sending Account' in the line
If Item.SendUsingAccount.DisplayName = "sending account" Then
to the display name of the account in question, presumably 'miky', though check the list of accounts to ensure you reproduce what is listed there exactly.
If so what is the error message?
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
i get compile error message or syntax error message . I believe because maybe paste the new code in wrong position ,
Michael
The macro intercepts the Send command? It does not work when creating a message
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
Dear Graham
Thanks for the all.
How about not give reference number to all Mails. Do we have any chance to create one button/icon and limitted to only giving reference code by pushing that button/icon while sending mail ?
regards
Bugra
The code is fabulous and works like a charm. The code is missing the most important point which is an Error Handler! The code is throwing the error in case of Last Number Value Check and since there is no handler in place, execution is coming to a break. in the Function xlGetNextNum, the actual error is coming as Null. Few Points here to be noted:
1) The code is not creating the supposed-to Excel file with the columns, Folder and the specified opening value in case of the value is missing in the Cell A1.
2) Incase of absence of the Existing Value which should be available by default, the code should enter the Value in the Cell A1, so that the code can be taken as reference for next number generation.
3) Insertion of Default Value to the Cell A1 in the sheet will also help in the Error Handling Process as it will simplify the handlers job, if any.
4) Code should also support reference numbers for thread responses.
5) Similarily, we should also work on the code which generates code for every we receive in our inbox (from a senders perspective)!
Could you please look into the points mentioned herein and help us further? I suggest that the error handler should be a part of Function xlGetNextNum.
Looking forward for your valuable help. Thanks in advance!
Valentin
Something like:
Errorhandler:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.DESCRIPTION _
, vbCritical, "Error!"
End
Your macro is working perfect except counting is always the same, not increasing for each mail. Can you please help me to fix this problem.
when i send e-mail reference number must be increase such as
first mail number references 2017001
second mail number references 2017002
third mail number references 2017003
fourth mail number references 2017004
can you please update macro like that.
and not working when i reply mails