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

Status
Not open for further replies.

nathandavies

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
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) which will be in the same location as the emails are saved.

Code:
 Option Explicit
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

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\")
  
   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
I have attached my code for your assistance.
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
I would put the two functions at the end of the code - it just makes it easier to read - i actually put mine in a module named 'functions' - they can be used by other macros and this makes it easy for me to see which functions i already have.

You have two options - you can either call the copy to excel macro first then save the message and delete or merge them. Either way, you should use the same object names (ie, olItem and oMail) - you need to make sure the object and variable names are referring to the correct field.

I *think* this is correct - i didn't test it.

Code:
 Option Explicit


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


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

' if this gives you trouble, change the enviro variable to another name for one use
    enviro = CStr(Environ("FILEDIRECTORY"))
    strFolderpath = BrowseForFolder(enviro & "\\NEWBENSON\Projects\")
 
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

'collect the fields
    strColA = oMail.SenderName
    strColB = oMail.SenderEmailAddress
    sName = oMail.Subject
    strColD = oMail.Body
    strColE = oMail.To
    strColF = oMail.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

' you need to use the same variable name - the one for the email address.
' original had a mix of strColB and strColC
Set recip = Application.Session.CreateRecipient(strColB)

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
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = 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) = sName
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF
'Next row
  rCount = rCount + 1
xlWB.Save

' because we replace bad characters after writing the cells,
' we can use the one subject variable
  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

xlSheet.Rows.WrapText = False

xlWB.Save
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
  
     Set oMail = Nothing
     Set obj = Nothing
     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


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
 

nathandavies

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server
Hi Diane,
I tried this but it did not open the excel document "Email Register" and save the information. this is the code i tried.

Code:
 Option Explicit
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


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 strColA, strColB, strColC, strColD, strColE, strColF As String

' Get Excel set up
enviro = CStr(Environ("FILEDIRECTORY"))
'the path of the workbook
strPath = enviro & "\Correspondence\Email Register.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

' if this gives you trouble, change the enviro variable to another name for one use
    enviro = CStr(Environ("FILEDIRECTORY"))
    strFolderpath = BrowseForFolder(enviro & "\\NEWBENSON\Projects\")
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem

'collect the fields
    strColA = oMail.SenderName
    strColB = oMail.SenderEmailAddress
    sName = oMail.Subject
    strColD = oMail.Body
    strColE = oMail.To
    strColF = oMail.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

' you need to use the same variable name - the one for the email address.
' original had a mix of strColB and strColC
Set recip = Application.Session.CreateRecipient(strColB)

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
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = 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) = sName
  xlSheet.Range("d" & rCount) = strColD
  xlSheet.Range("e" & rCount) = strColE
  xlSheet.Range("f" & rCount) = strColF
'Next row
  rCount = rCount + 1
xlWB.Save

' because we replace bad characters after writing the cells,
' we can use the one subject variable
  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

xlSheet.Rows.WrapText = False

xlWB.Save
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
 
     Set oMail = Nothing
     Set objItem = Nothing
     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


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
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Any error messages? Comment out the on error lines so the errors come up.
 
Status
Not open for further replies.
Top