outlook değişken mail başlığı

[ADEMES]

Selamlar ,

outlookta otomatik olarak gönderilen her mail için artan bir referans numarası verilsin ve yanınada tarih atılsın. Bu detaylar mailin en üst kısmına otomatik olarak koyulsun.

örnek : Ref AE-001 ( her mailde artacak )

bu giden mailler başka bir excel dosyasına baslık , kime , saat detayıyla kayıt edilsin.

saygılarımla
adem

 

[ADEMES]

Aşağıda ki gibi bir macro buldum ama sadece Ref-1 Atıyor.

bunu Ref: 1000001.AE 2017/11/27 16.47 şeklinde yapabilir miyiz.

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