Results 1 to 1 of 1

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

Threaded View

nathandavies9 Email Details to Excel & Save... 03-21-2017, 12:17 PM
  1. #1
    Registered User
    Join Date
    02-21-2017
    Location
    Castelford
    MS-Off Ver
    2013
    Posts
    89

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

    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.

    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
    I have attached my code for your assistance.
    Attached Files Attached Files

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Select range in excel and save as text file & email - Macro
    By harryco79 in forum Excel Programming / VBA / Macros
    Replies: 15
    Last Post: 06-12-2015, 12:21 PM
  2. Excel Macro to extract Email Details from Outlook specific Mailbox
    By christlivethinme in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 05-06-2015, 08:13 AM
  3. Save Email Details in excel file
    By s_samira_21 in forum Outlook Programming / VBA / Macros
    Replies: 0
    Last Post: 08-06-2014, 04:12 AM
  4. Macro - Save Word as PDF with Unique Name and Email PDF to specified email address.
    By newbie1234 in forum Word Programming / VBA / Macros
    Replies: 6
    Last Post: 07-08-2014, 11:54 PM
  5. Replies: 2
    Last Post: 02-25-2013, 10:40 AM
  6. Export email details to excel based on folder
    By aravindhan_31 in forum Outlook Programming / VBA / Macros
    Replies: 0
    Last Post: 03-01-2011, 12:36 AM
  7. Can I get excel to auto save details from a cell into the doc nam.
    By excelnewbie in forum Excel Formulas & Functions
    Replies: 3
    Last Post: 09-16-2005, 03:05 AM

Bookmarks

Posting Permissions

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

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1