Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 21

Thread: Outlook 2013 auto reference number

  1. #1

    Outlook 2013 auto reference number

    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.

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

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

    Quote Originally Posted by gmayor View Post
    Καλημέρα 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

  4. #4
    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

  5. #5

    Thank you

    Its works perfect !
    I really appreciate your help.

    Thank you again
    Mike from Athens


    Quote Originally Posted by gmayor View Post
    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

  6. #6
    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

  7. #7
    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

  8. #8

    vba code

    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

  9. #9
    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

  10. #10
    Dear graham

    thank you very much.

  11. #11
    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

  12. #12
    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

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

  14. #14
    VBAX Newbie
    Joined
    Sep 2015
    Posts
    1
    Location

    Wink Can it be done when New mail opens

    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.

    Quote Originally Posted by mike1881 View Post
    Its works perfect !
    I really appreciate your help.

    Thank you again
    Mike from Athens

  15. #15
    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

  16. #16
    VBAX Newbie
    Joined
    Nov 2015
    Posts
    1
    Location
    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

  17. #17

    Missing Error Handler!!

    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

    Quote Originally Posted by gmayor View Post
    Καλημέρα 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

  18. #18
    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

  19. #19
    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.

  20. #20
    and not working when i reply mails

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •