Consulting

Results 1 to 8 of 8

Thread: Need to consolidate outlook basic details and excel attachment field details

  1. #1

    Exclamation Need to consolidate outlook basic details and excel attachment field details

    We receive 3000+ emails monthly with attached Excel workbooks. We copy email details and data from attached Excel files to a master file.

    Each email will have one attached Excel file. Ignore attached pdf notepad files.

    I am using multiple shared email boxes so that user can pick whichever shared email box and folder as well..

    Outlook details can be copied to master data with below code.

    How do I copy data in the attachment fileds to my master Excel file? ( save the attachment if helpful here )

    Much appreciated for your help to resolve below issue

    Option Explicit

    Sub GetMailInfo()
    Dim results() As String
    ' get contacts
    results = ExportEmails(True)
    ' paste onto worksheet
    Range(Cells(1, 1),
    Cells(UBound(results),
    UBound(results, 2))).Value
    = results

    MsgBox "Completed"
    End Sub


    Function ExportEmails(Optional
    headerRow As Boolean = False) As
    String()

    Dim objOutlook As Object '
    Outlook.Application
    Dim objNamespace As Object '
    Outlook.Namespace
    Dim strFolderName As Object
    Dim objMailbox As Object
    Dim objFolder As Object
    Dim mailFolderItems As Object '
    Outlook.items
    Dim folderItem As Object
    Dim msg As Object ' Outlook.MailItem
    Dim tempString() As String
    Dim i As Long
    Dim numRows As Long
    Dim startRow As Long
    Dim jAttach As Long ' counter for
    attachments
    Dim debugMsg As Integer

    ' select output results worksheet and
    clear previous results
    Sheets("Outlook Results").Select
    Sheets("Outlook
    Results").Cells.ClearContents
    Range("A1").Select

    Set objOutlook =
    CreateObject("Outlook.Application")
    'MsgBox objOutlook, vbOKOnly 'for
    debugging
    Set objNamespace =
    objOutlook.GetNamespace("MAPI")
    'MsgBox objNamespace, vbOKOnly 'for
    debugging
    'Set objInbox =
    objNamespace.GetDefaultFolder(olFolderInbox)
    'MsgBox objInbox, vbOKOnly 'for debugging
    Set strFolderName = objNamespace.PickFolder
    Set mailFolderItems = strFolderName.Items

    ' if calling procedure wants header row
    If headerRow Then
    startRow = 1
    Else
    startRow = 0
    End If

    numRows = mailFolderItems.Count
    ' resize array
    ReDim tempString(1 To (numRows + startRow), 1 To 100)
    ' loop through folder items
    For i = 1 To numRows
    Set folderItem = mailFolderItems.Item(i)

    If IsMail(folderItem) Then
    Set msg = folderItem
    End If

    With msg
    tempString(i + startRow, 1) = .ReceivedByName
    tempString(i + startRow, 2) = .ReceivedTime
    tempString(i + startRow, 3) = .SenderEmailAddress
    tempString(i + startRow, 4) = .SenderName
    tempString(i + startRow, 5) = .SentOn
    tempString(i + startRow, 6) = .Size
    tempString(i + startRow, 7) = .Subject
    tempString(i + startRow, 8) = .To
    End With

    ' adding file attachment names where they exist - added by JP
    If msg.Attachments.Count > 0 Then
    For jAttach = 1 To msg.Attachments.Count
    tempString(i + startRow, 39 + jAttach) =



    msg.Attachments.Item(jAttach).DisplayName
    Next jAttach
    End If
    Next i

    ' first row of array should be header
    values
    If headerRow Then
    tempString(1, 1) = "ReceivedByName"
    tempString(1, 2) = "ReceivedTime"
    tempString(1, 3) = "SenderEmailAddress"
    tempString(1, 4) = "SenderName"
    tempString(1, 5) = "SentOn"
    tempString(1, 6) = "size"
    tempString(1, 7) = "subject"
    tempString(1, 8) = "To"
    End If

    ExportEmails = tempString

    ' apply pane freeze and filtering

    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Rows("1:1").Select
    'Selection.AutoFilter
    End Function


    Function IsMail(itm As Object) As
    Boolean
    IsMail = (TypeName(itm) = "MailItem")
    End Function


    Column L is only counts of line in attachment excel lines

    Could you please help me

    Thank you
    Attached Images Attached Images
    Last edited by rahulsmile; 08-18-2021 at 07:40 AM. Reason: Attachment is not clear

  2. #2
    Sub GetMailInfo()
        Dim results() As String
        ' get contacts
        results = ExportEmails(True)
        ' paste onto worksheet
        Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
        MsgBox "Completed"
    End Sub
    
    
    
    
    Function ExportEmails(Optional headerRow As Boolean = False) As String()
    
    
        Dim objOutlook As Object 'Outlook.Application
        Dim objNamespace As Object 'Outlook.Namespace
        Dim strFolderName As Object
        Dim objMailbox As Object
        Dim objFolder As Object
        Dim mailFolderItems As Object 'Outlook.Items
        Dim folderItem As Object
        Dim msg As Object ' Outlook.MailItem
        Dim tempString() As String
        Dim i As Long
        Dim numRows As Long
        Dim startRow As Long
        Dim jAttach As Long ' counter for Attachments
        Dim debugMsg As Integer
        'arnelgp
        Dim Country, Department, Lines, Typ, Itm1, Itm2
        Dim strAttach As String, strPath As String
        Dim objAttach As Object
        
        strPath = Environ$("temp") & "\"
        
        ' select output results worksheet and clear previous results
        Sheets("Outlook Results").Select
        Sheets("Outlook results").Cells.ClearContents
        Range("A1").Select
        
        Set objOutlook = CreateObject("Outlook.Application")
        'MsgBox objOutlook, vbOKOnly 'for debugging
        Set objNamespace = objOutlook.GetNamespace("MAPI")
        'MsgBox objNamespace, vbOKOnly 'for debugging
        'Set objInbox = objNamespace.GetDefaultFolder (olFolderInbox)
        'MsgBox objInbox, vbOKOnly 'for debugging
        Set strFolderName = objNamespace.PickFolder
        Set mailFolderItems = strFolderName.Items
        
        ' if calling procedure wants header row
        If headerRow Then
            startRow = 1
        Else
            startRow = 0
        End If
        
        numRows = mailFolderItems.Count
        ' resize array
        ReDim tempString(1 To (numRows + startRow), 1 To 100)
        ' loop through folder items
        For i = 1 To numRows
            Set folderItem = mailFolderItems.Item(i)
            
            If IsMail(folderItem) Then
                Set msg = folderItem
            End If
        
            With msg
                tempString(i + startRow, 1) = .ReceivedByName
                tempString(i + startRow, 2) = .ReceivedTime
                tempString(i + startRow, 3) = .SenderEmailAddress
                tempString(i + startRow, 4) = .SenderName
                tempString(i + startRow, 5) = .SentOn
                tempString(i + startRow, 6) = .Size
                tempString(i + startRow, 7) = .Subject
                tempString(i + startRow, 8) = .To
            End With
        
            ' adding file attachment names where they exist - added by JP
            If msg.Attachments.Count > 0 Then
                For jAttach = 1 To msg.Attachments.Count
                    Set objAttach = msg.Attachments.Item(jAttach)
                    strAttach = msg.Attachments.Item(jAttach).DisplayName
                    tempString(i + startRow, 39 + jAttach) = strAttach
                    
                    'arnelgp
                    If Right$(strAttach, 4) = ".xls" Or _
                            Right$(strAttach, 5) Like ".xls*" Then
                            
                            Country = "": Department = "": Lines = 0
                            Typ = "": Itm1 = "": Itm2 = ""
                            
                            On Error Resume Next
                            Kill strPath & strAttach
                            
                            objAttach.SaveAsFile strPath & strAttach
                            
                            Call ProcessWB(strPath & strAttach, Country, Department, Lines, Typ, Itm1, Itm2)
                            
                            Set objAttach = Nothing
                            tempString(i + startRow, 9) = Country
                            tempString(i + startRow, 10) = Department
                            tempString(i + startRow, 11) = Lines
                            tempString(i + startRow, 12) = Typ
                            tempString(i + startRow, 13) = Itm1
                            tempString(i + startRow, 14) = Itm2
                    End If
                Next jAttach
            End If
        Next i
        
        ' first row of array should be header Values
        If headerRow Then
            tempString(1, 1) = "ReceivedByName"
            tempString(1, 2) = "ReceivedTime"
            tempString(1, 3) = "SenderEmailAddress"
            tempString(1, 4) = "SenderName"
            tempString(1, 5) = "SentOn"
            tempString(1, 6) = "size"
            tempString(1, 7) = "subject"
            tempString(1, 8) = "To"
            'arnelgp
            tempString(1, 9) = "Country"
            tempString(1, 10) = "Department"
            tempString(1, 11) = "No. of line items count"
            tempString(1, 12) = "Type"
            tempString(1, 13) = "Item1"
            tempString(1, 14) = "Item2"
        End If
        
        ExportEmails = tempString
        
        ' apply pane freeze and filtering
        
        Range("A2").Select
        ActiveWindow.FreezePanes = True
        Rows("1:1").Select
        'Selection.AutoFilter
    End Function
    
    
    
    
    Function IsMail(itm As Object) As Boolean
    IsMail = (TypeName(itm) = "MailItem")
    End Function
    
    
    'arnelgp
    Public Function ProcessWB(ByVal wbName As String, _
                    ByRef Country, _
                    ByRef Dept, _
                    ByRef Lines, _
                    ByRef Typ, _
                    ByRef Itm1, _
                    ByRef Itm2) As Boolean
        Static objExcel As Excel.Application
        Dim wb As Workbook, sh As Worksheet
        If objExcel Is Nothing Then
            Set objExcel = New Excel.Application
        End If
        Set wb = objExcel.Workbooks.Open(wbName)
        Set sh = wb.Sheets(1)
        With sh
            Country = .Range("A2") & ""
            Dept = .Range("B2") & ""
            Typ = .Range("D2") & ""
            Itm1 = .Range("K2") & ""
            Itm2 = .Range("L2") & ""
            Lines = .Cells(.Rows.Count, 1).End(xlUp).Row - 3
        End With
        Set sh = Nothing
        wb.Close False
        Set wb = Nothing
    End Function

  3. #3
    Beautiful it is perfectly working fine .... Thank you so much .... Am impressed by looking perfect code how can I donate you small gift from myside

  4. #4
    One additional just for information Count of line from attachment am getting .... In future if I want to add SUM formula how to use I tried but it not picked

  5. #5
    Quote Originally Posted by rahulsmile View Post
    One additional just for information Count of line from attachment am getting .... In future if I want to add SUM formula how to use I tried but it not picked
    can you add it manually upong completion of the VBA?

  6. #6
    Not an issue .... I must thankful for your efforts please let me know how can I send some donation

  7. #7
    i am still new to this forum (see 35 post only).
    you should direct your enquiries to the moderators of this forum.

    i see on the upper menu, there is paypal donation. click it and see.

  8. #8
    Thank you

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
  •