Email Details to Excel & Save as .MSG on one macro - combination of 2 macros

**nathandavies** · 03-21-2017, 09:00 AM

Hi all, I have a macro at the minute which i have found and changed to suit my needs which saves an email in a file location on my server at work. I have just found another macro which inputs details from an email message into an excel spreadsheet. i was wondering if anyone would be able to help me combine the two macros so it completes both on one macro. When i select the file location to save the email it save the details to an excel spreadsheet (called Email Register - COPY ATTACHED) which will be in the same location as the emails are saved.

I have attached my code for your assistance.

 Option ExplicitFunction BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
 On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0
 
 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function
 
Invalid:
 BrowseForFolder = False
End Function


Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  Dim strFolderpath As String
  Dim objItem As Outlook.MailItem
  
    enviro = CStr(Environ("FILEDIRECTORY"))
    strFolderpath = BrowseForFolder(enviro & "\\NEWBENSON\Projects\Drawings")
   
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
    
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
  
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
      
  sPath = strFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMsg
   
  End If
  Next
          If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then
            oMail.Delete
        End If
   
End Sub


Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub


 Sub CopyToExcel()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String


Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
 Dim obj As Object
 Dim olItem 'As Outlook.MailItem
 Dim strColA, strColB, strColC, strColD, strColE, strColF As String
               
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0


On Error Resume Next
  ' Open the workbook to input the data
  ' Create workbook if doesn't exist
     Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
      xlWB.SaveAs FileName:=strPath
End If
   On Error GoTo 0
     Set xlSheet = xlWB.Sheets("Sheet1")
    
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
  xlSheet.Range("A1") = "Sender Name"
  xlSheet.Range("B1") = "Sender Email"
  xlSheet.Range("C1") = "Subject"
  xlSheet.Range("D1") = "Body"
  xlSheet.Range("E1") = "Sent To"
  xlSheet.Range("F1") = "Date"
End If


'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1


' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
    Set objItems = objFolder.Items
  For Each obj In objItems


    Set olItem = obj
    
 'collect the fields
 
    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    strColC = olItem.Subject
    strColD = olItem.Body
    strColE = olItem.To
    strColF = olItem.ReceivedTime
    


' Get the Exchange address
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColC)


 If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
     Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColC = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' End Exchange section


'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA
  xlSheet.Range("B" & rCount) = strColB
  xlSheet.Range("c" & rCount) = strColC
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF
 
'Next row
  rCount = rCount + 1
xlWB.Save


 Next
 
' don't wrap lines
xlSheet.Rows.WrapText = False


xlWB.Save
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
    
     Set olItem = Nothing
     Set obj = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

Email Register.xlsx

I have also attached the excel spreadsheet i would like to save the emails to also.
[/CODE]

**gmayor** · 03-21-2017, 11:08 PM

There are some strange anomalies in your code relating to the use of Environ, where you appear to have made up your own environment variable. If the location is a network path, use the correct network path. If the network path varies by user name then use the Environ("USERNAME") variable to get that variable name.

Unless you want to prompt separately for each deleting out that prompt before the loop. You can call your second macro from the first, though you will need to make a few minor changes.

I have not tested any of this because I don't have your messages or the folder locations (or access to an Exchange Mail Server) but it should get you closer if the two macros worked before (I have moved the minor functions to the end):

Option Explicit

Public Sub SaveMessageAsMsg()
Dim dtDate As Date
Dim sName As String
Dim strFolderpath As String
Dim objItem As Outlook.MailItem
Dim lngDelete As Long
    'enviro = CStr(Environ("FILEDIRECTORY")) 'This location does not exist

strFolderpath = BrowseForFolder("\\NEWBENSON\Projects\Drawings\")    '/?
    lngDelete = MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?")
    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            sName = objItem.Subject
            sName = ReplaceCharsForFileName(sName, "_")
            dtDate = objItem.ReceivedTime
            sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
                           vbUseSystem) & Format(dtDate, "-hhnnss", _
                                                 vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
            objItem.SaveAs strFolderpath & sName, olMsg
        End If
        CopyToExcel objItem
        If lngDelete = vbYes Then
            objItem.Delete
        End If
    Next objItem
    Set objItem = Nothing
End Sub

Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String

Dim objFolder As Outlook.MAPIFolder
Dim strColA, strColB, strColC, strColD, strColE, strColF As String

    ' Get Excel set up
    enviro = CStr(Environ("USERPROFILE"))
    'the path of the workbook
    strPath = enviro & "\Documents\Book1.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error Resume Next
    ' Open the workbook to input the data
    ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs fileName:=strPath
    End If
    On Error GoTo 0
    Set xlSheet = xlWB.Sheets("Sheet1")

    On Error Resume Next
    ' add the headers if not present
    If xlSheet.Range("A1") = "" Then
        xlSheet.Range("A1") = "Sender Name"
        xlSheet.Range("B1") = "Sender Email"
        xlSheet.Range("C1") = "Subject"
        xlSheet.Range("D1") = "Body"
        xlSheet.Range("E1") = "Sent To"
        xlSheet.Range("F1") = "Date"
    End If

    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
    'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1

    'collect the fields

    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    strColC = olItem.Subject
    strColD = olItem.Body
    strColE = olItem.To
    strColF = olItem.ReceivedTime



    ' Get the Exchange address
    ' if not using Exchange, this block can be removed
    Dim olEU As Outlook.exchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim recip As Outlook.Recipient
    Set recip = Application.Session.CreateRecipient(strColC)


    If InStr(1, strColB, "/") > 0 Then
        ' if exchange, get smtp address
        Select Case recip.AddressEntry.AddressEntryUserType
            Case OlAddressEntryUserType.olExchangeUserAddressEntry
                Set olEU = recip.AddressEntry.GetExchangeUser
                If Not (olEU Is Nothing) Then
                    strColC = olEU.PrimarySmtpAddress
                End If
            Case OlAddressEntryUserType.olOutlookContactAddressEntry
                Set olEU = recip.AddressEntry.GetExchangeUser
                If Not (olEU Is Nothing) Then
                    strColC = olEU.PrimarySmtpAddress
                End If
            Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
                Set oEDL = recip.AddressEntry.GetExchangeDistributionList
                If Not (oEDL Is Nothing) Then
                    strColC = olEU.PrimarySmtpAddress
                End If
        End Select
    End If
    ' End Exchange section


    'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
    xlSheet.Range("f" & rCount) = strColF

    'Next row
    rCount = rCount + 1
    xlWB.Save

    ' don't wrap lines
    xlSheet.Rows.WrapText = False


    xlWB.Save
    xlWB.Close 1

    If bXStarted Then
        'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Private Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
    Exit Function

Invalid:
    BrowseForFolder = False
End Function

Private Function ReplaceCharsForFileName(sName As String, _
                                         sChr As String) As String
    sName = Replace(sName, "'", sChr)
    sName = Replace(sName, "*", sChr)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
End Function

**nathandavies** · 03-22-2017, 03:06 AM

Thanks Graham, I have changed my code now to suit some code you have given me on a different post. The problem i'm having is it doesn't have the same file path as the "save email", i would like it to use the same file path as the Save Email macro but without having to input the folder locations again, is this possible?

Option ExplicitSub SaveMessage()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    If Not TypeName(olMsg) = "MailItem" Then
        MsgBox "Select a mail item!"
        GoTo lbl_Exit
    End If
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub
 
Sub SaveItem(olItem As MailItem)
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
    fPath2 = InputBox("Enter the project name and number.", _
    "Save Message")
    fPath2 = Replace(fPath2, "\", "")
     
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Sent"
    CreateFolders strPath & "\Received"
     
    If olItem.Sender Like "*@email.co.uk" Then
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
lbl_Exit:
    Exit Sub
End Sub
 
Private Sub CreateFolders(strPath As String)
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub
 
Private Function SaveUnique(oItem As Object, _
    strPath As String, _
    strFileName As String)
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function
 
Private Function FileExists(filespec As String) 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
Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim enviro As String
    Dim strPath As String
     
    Dim objFolder As Outlook.MAPIFolder
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String
     
     ' Get Excel set up
    enviro = CStr(Environ("USERPROFILE"))
     'the path of the workbook
    strPath = enviro & "\Documents\Book1.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error Resume Next
     ' Open the workbook to input the data
     ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs FileName:=strPath
    End If
    On Error GoTo 0
    Set xlSheet = xlWB.Sheets("Sheet1")
     
    On Error Resume Next
     ' add the headers if not present
    If xlSheet.Range("A2") = "" Then
        xlSheet.Range("A2") = "Sender Name"
        xlSheet.Range("B2") = "Sent To"
        xlSheet.Range("C2") = "Subject"
        xlSheet.Range("D2") = "Body"
        xlSheet.Range("E2") = "Date"
    End If
     
     'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
     'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1
     
     'collect the fields
     
    strColA = olItem.SenderName
    strColB = olItem.To
    strColC = olItem.Subject
    strColD = olItem.Body
    strColE = olItem.ReceivedTime


             
     ' Get the Exchange address
     ' if not using Exchange, this block can be removed
    Dim olEU As Outlook.ExchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim recip As Outlook.Recipient
    Set recip = Application.Session.CreateRecipient(strColC)
     
     
    If InStr(1, strColB, "/") > 0 Then
         ' if exchange, get smtp address
        Select Case recip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olOutlookContactAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = recip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        End Select
    End If
     ' End Exchange section
     
     
     'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
     
     'Next row
    rCount = rCount + 1
    xlWB.Save
          ' don't wrap lines
    xlSheet.Rows.WrapText = True
    xlWB.Save
    xlWB.Close 1
     
    If bXStarted Then
         'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

**gmayor** · 03-22-2017, 03:36 AM

I am not sure what you mean. You can pass a folder path to another macro as shown in the CreateFolders macro, so you only have to declare it once.
Incidentally the CreateFolders function creates the whole path, so you don't have to create the individual parts separately thus

'CreateFolders strPath 'This line is superfluous
CreateFolders strPath & "\Sent"
CreateFolders strPath & "\Received"

**nathandavies** · 03-22-2017, 04:38 AM

 enviro = CStr(Environ("USERPROFILE"))
     'the path of the workbook
    strPath = fRootPath & fPath1 & "\" & fPath2 & "\Correspondence\Email Register.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If

This is the code i'm having trouble with, i would like to make it the same path as this bit of code

Sub SaveItem(olItem As MailItem) [/COLOR]    Dim fname As String 
    Dim fPath1 As String, fPath2 As String 
    Dim strPath As String 
    Const fRootPath As String = "\\NEWBENSON\Projects\drawings\" 
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _ 
    "The path will be created if it doesn't exist.", _ 
    "Save Message") 
    fPath1 = Replace(fPath1, "\", "") 
    fPath2 = InputBox("Enter the project name and number.", _ 
    "Save Message") 
    fPath2 = Replace(fPath2, "\", "") 
          strPath = fRootPath & fPath1 & "\" & fPath2

**gmayor** · 03-22-2017, 05:07 AM

Change as follows

Sub CopyToExcel(olItem As MailItem, strFolder As String)

Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim strPath As String

Dim objFolder As Outlook.MAPIFolder
Dim strColA, strColB, strColC, strColD, strColE, strColF As String

    ' Get Excel set up
    'the path of the workbook
    Do Until Right(strFolder, 1) = Chr(92)
        strFolder = strFolder & Chr(92)
    Loop
    strPath = strFolder & "Documents\Book1.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
'etc

and then call the sub from the other sub e.g.

    oItem.SaveAs strPath & strFileName & ".msg"
    CopyToExcel olItem, strPath 'call the Excel sub
lbl_Exit:
    Exit Function
End Function

**nathandavies** · 03-22-2017, 05:54 AM

Graham, I'm not sure where i need to call the sub from?

Option ExplicitSub SaveMessage()
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    If Not TypeName(olMsg) = "MailItem" Then
        MsgBox "Select a mail item!"
        GoTo lbl_Exit
    End If
    SaveItem olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub
 
Sub SaveItem(olItem As MailItem)
    Dim fname As String
    Dim fPath1 As String, fPath2 As String
    Dim strPath As String
    Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
    fPath2 = InputBox("Enter the project name and number.", _
    "Save Message")
    fPath2 = Replace(fPath2, "\", "")
     
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"
     
    If olItem.Sender Like "*@email.co.uk" Then
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
        Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
        Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
lbl_Exit:
    Exit Sub
End Sub
 
Private Sub CreateFolders(strPath As String)
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
        Exit Sub
End Sub
 
Private Function SaveUnique(oItem As Object, _
    strPath As String, _
    strFileName As String)
    Dim lngF As Long
    Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function
 
Private Function FileExists(filespec As String) 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
Sub CopyToExcel(olItem As MailItem, strFolder As String)
     
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim strPath As String
     
    Dim objFolder As Outlook.MAPIFolder
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String
     
     ' Get Excel set up
     'the path of the workbook
    Do Until Right(strFolder, 1) = Chr(92)
        strFolder = strFolder & Chr(92)
    Loop
    strPath = strFolder & "correspondence\email register.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
     'etc


    End If
    On Error Resume Next
     ' Open the workbook to input the data
     ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath)
    If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs FileName:=strPath
    End If
    On Error GoTo 0
    Set xlSheet = xlWB.Sheets("email")
     
    On Error Resume Next
     ' add the headers if not present
    If xlSheet.Range("A8") = "" Then
        xlSheet.Range("A8") = "Sender Name"
        xlSheet.Range("B8") = "Sent To"
        xlSheet.Range("C8") = "Date"
        xlSheet.Range("D8") = "Subject"
        xlSheet.Range("E8") = "Body"
    End If
     
     'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
     'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1
     
     'collect the fields
     
    strColA = olItem.SenderName
    strColB = olItem.To
    strColC = olItem.ReceivedTime
    strColD = olItem.Subject
    strColE = olItem.Body


             
     ' Get the Exchange address
     ' if not using Exchange, this block can be removed
    Dim olEU As Outlook.ExchangeUser
    Dim oEDL As Outlook.ExchangeDistributionList
    Dim recip As Outlook.Recipient
    Set recip = Application.Session.CreateRecipient(strColC)
     
     
    If InStr(1, strColB, "/") > 0 Then
         ' if exchange, get smtp address
        Select Case recip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olOutlookContactAddressEntry
            Set olEU = recip.AddressEntry.GetExchangeUser
            If Not (olEU Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = recip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                strColC = olEU.PrimarySmtpAddress
            End If
        End Select
    End If
     ' End Exchange section
     
     
     'write them in the excel sheet
    xlSheet.Range("A" & rCount) = strColA
    xlSheet.Range("B" & rCount) = strColB
    xlSheet.Range("c" & rCount) = strColC
    xlSheet.Range("d" & rCount) = strColD
    xlSheet.Range("e" & rCount) = strColE
     
     'Next row
    rCount = rCount + 1
    xlWB.Save
     
     ' don't wrap lines
    xlSheet.Rows.WrapText = False
     
     
    xlWB.Save
    xlWB.Close 1
     
    If bXStarted Then
         'xlApp.Quit 'With looped messages it will be faster if Excel is not closed
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

this is the full code

**gmayor** · 03-23-2017, 01:33 AM

I have lost track of this, as well as the will to live, as you keep changing it; but based on your last version it goes where indicated

Sub SaveItem(olItem As MailItem)
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
    fPath1 = InputBox("Enter the customer folder name in which to save the message." & vbCr & _
                      "The path will be created if it doesn't exist.", _
                      "Save Message")
    fPath1 = Replace(fPath1, "\", "")
    fPath2 = InputBox("Enter the project name and number.", _
                      "Save Message")
    fPath2 = Replace(fPath2, "\", "")

    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Correspondence" & "\Sent"
    CreateFolders strPath & "\Correspondence" & "\Received"

    If olItem.sender Like "*@email.co.uk" Then 'Looks for messages from you
        fname = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Sent\" & fname
    Else
        fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        fname = "Correspondence\Received\" & fname
    End If
    fname = Replace(fname, Chr(58) & Chr(41), "")
    fname = Replace(fname, Chr(58) & Chr(40), "")
    fname = Replace(fname, Chr(34), "-")
    fname = Replace(fname, Chr(42), "-")
    fname = Replace(fname, Chr(47), "-")
    fname = Replace(fname, Chr(58), "-")
    fname = Replace(fname, Chr(60), "-")
    fname = Replace(fname, Chr(62), "-")
    fname = Replace(fname, Chr(63), "-")
    fname = Replace(fname, Chr(124), "-")
    SaveUnique olItem, strPath, fname
    CopyToExcel olItem, strPath 'The line goes here
lbl_Exit:
    Exit Sub
End Sub

**nathandavies** · 03-23-2017, 01:59 AM

Graham, i'm sorry about all the changes but this now works and it opens excel and saves the information as it should which is great!

thank you for your continued help on this!

Regards
ND

Thread: Email Details to Excel & Save as .MSG on one macro - combination of 2 macros

Thread Tools

Display

Email Details to Excel & Save as .MSG on one macro - combination of 2 macros

Tags for this Thread

Posting Permissions