Outlook 2013 auto reference number

[mike1881]

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.

[gmayor]

Καλημέρα 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

[mike1881]

Καλημέρα
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


Καλημέρα 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

[gmayor]

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

[mike1881]

Its works perfect !
I really appreciate your help.

Thank you 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

[mike1881]

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

[gmayor]

If I understand correctly, you can use the same code in each profile.

[mike1881]

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

[gmayor]

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

[mike1881]

Dear graham

thank you very much.

[mike1881]

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

[gmayor]

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?

[mike1881]

i get compile error message or syntax error message . I believe because maybe paste the new code in wrong position ,
Michael

[billoo]

Thanks it works fine for ItemSend
Can you please edit to work when new mail is opened so that i can check and edit (if needed) before sending.
It is obvious that i have no knowledge of coding.


Its works perfect !
I really appreciate your help.

Thank you again
Mike from Athens

[gmayor]

The macro intercepts the Send command? It does not work when creating a message

[erkutcan]

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

[yuvraj143]

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


Καλημέρα 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

[yuvraj143]

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

[ademeskici]

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.

[ademeskici]

and not working when i reply mails :(

[ademeskici]

and not working when i reply mails :(