none
How to copy files from Outlook with same subject? RRS feed

  • Question

  • The VBA below can copy files from Outlook to C:\ :
    Sub wEaddressAtC()
    
    If ActiveCell <> "From sender email" Then Exit Sub
        Dim objNS As Outlook.Namespace
        Dim objFolder As Outlook.MAPIFolder
        Dim path As String
        Set objNS = GetNamespace("MAPI")
        Set objFolder = objNS.Folders("Ivan emailabc-Sundries for others")
        Set objFolder = objFolder.Folders("Get Email")
            
    For Each Item In objFolder.Items
                
                If TypeName(Item) = "MailItem" Then
                If Item.Sender <> "K K Lo" And (Not InStr(Item.Sender, "Mail") > 0 And Not InStr(Item.Sender, "MAIL") > 0 And Not InStr(Item.Sender, "post") > 0) Then
                If Not InStr(Item.Subject, "size") > 0 Then
                If Not InStr(Item.Body, "regret") > 0 Then
                        
                        With CreateObject("VBSCRIPT.REGEXP")
                            .Global = True
                            .Pattern = "[\\/:*?|<>]"
                            tmpSubject = .Replace(Item.Subject, "")
                        End With
                    path = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\" & tmpSubject & ".msg"
                    Item.SaveAs (path)
                  
                 End If
                 End If
                 End If
                 End If
            Next
    End Sub
    

    but if the files have the same subject, only one file is copied even

    they are from different senders.
    How to revise VBA so that all files with same subject can be copied
    whether they are from different or same senders?
    Friday, December 1, 2017 3:34 AM

Answers

  • Hi london7871,

    Sorry for my careless, please use FullPathStr to save the file.

    Item.SaveAs (FullPathStr)

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by london7871 Monday, December 4, 2017 4:01 AM
    Monday, December 4, 2017 2:25 AM

All replies

  • Hi london7871,

    Since these mails have same subject, it would have same filename when saving. So it would cover previous saved file.

    I would suggest you check if the filename exist before saving and add order index if it exist, such as Subject_1.msg, Subject_2.msg, etc...

    Here is the simply code. You could try to adjust it for your need.

    PathStr = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\"
    NameStr = tmpSubject
    TypeStr = ".msg"
    
    i = 0
    FullPathStr = PathStr & NameStr & TypeStr
    If Dir(FullPathStr) = "" Then
    Item.SaveAs (Path)
    Else
        Do
          i = i + 1
          FullPathStr = PathStr & NameStr & "_" & i & TypeStr
          If Dir(FullPathStr) = "" Then Exit Do
        Loop
        Item.SaveAs (Path)
    End If

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, December 1, 2017 5:54 AM
  • How to insert your VBA into my VBA?
    Saturday, December 2, 2017 5:12 AM
  • Hi london7871,

    You could use it to replace below code in your macro.

    path = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\" & tmpSubject & ".msg"
                    Item.SaveAs (path)

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, December 4, 2017 1:19 AM
  • Upon revised the VBA as below, there is error at the first Item.SaveAs (Path) with message:
    execution error '5'
    call or number not correct
    Sub CEaddressAtC()
             
             Dim objNS As Outlook.Namespace
             Dim objFolder As Outlook.MAPIFolder
             Dim path As String
             Set objNS = GetNamespace("MAPI")
             Set objFolder = objNS.Folders("Ivan emailabc-Sundries for others")
             Set objFolder = objFolder.Folders("Get Email")
                 
                 For Each Item In objFolder.Items
                     
                     If TypeName(Item) = "MailItem" Then
                             
                             With CreateObject("VBSCRIPT.REGEXP")
                                 .Global = True
                                 .Pattern = "[\\/:*?|<>]"
                                 tmpSubject = .Replace(Item.Subject, "")
                             End With
                         
    '                     path = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\" & tmpSubject & ".msg"
    '                     Item.SaveAs (path)
                       
                PathStr = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\"
    NameStr = tmpSubject
    TypeStr = ".msg"
    
    i = 0
    FullPathStr = PathStr & NameStr & TypeStr
    If Dir(FullPathStr) = "" Then
    Item.SaveAs (path)
    Else
        Do
          i = i + 1
          FullPathStr = PathStr & NameStr & "_" & i & TypeStr
          If Dir(FullPathStr) = "" Then Exit Do
        Loop
        Item.SaveAs (path)
    End If
    
                      
                      End If
                 Next
             
    
    'Copy filename from folder to excel
            Dim olApp As Outlook.Application
            Set olApp = CreateObject("Outlook.Application")
            Dim ns As Outlook.Namespace
            Set ns = olApp.GetNamespace("MAPI")
            Dim mail As MailItem
            FolderPath = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\" '<<<<<<<<<<<<<<<<<<<
            MsgFile = Dir(FolderPath & "*.msg")
            i = 4
            Do While MsgFile <> ""
            Set itm = ns.OpenSharedItem(FolderPath & MsgFile)
            If TypeName(itm) = "MailItem" Then
            Set mail = itm
                    ActiveSheet.Cells(i, 1) = mail.Subject
                    ActiveSheet.Cells(i, 4) = mail.SenderEmailAddress
            i = i + 1
            End If
            MsgFile = Dir
            Loop
    
    End Sub
    
    

    Monday, December 4, 2017 1:59 AM
  • Hi london7871,

    Sorry for my careless, please use FullPathStr to save the file.

    Item.SaveAs (FullPathStr)

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by london7871 Monday, December 4, 2017 4:01 AM
    Monday, December 4, 2017 2:25 AM
  • Thanks Terry, it's work as per your revision:
    Sub CEaddressAtC()
             
             Dim objNS As Outlook.Namespace
             Dim objFolder As Outlook.MAPIFolder
             Dim path As String
             Set objNS = GetNamespace("MAPI")
             Set objFolder = objNS.Folders("Ivan emailabc-Sundries for others")
             Set objFolder = objFolder.Folders("Get Email")
                 
                 For Each Item In objFolder.Items
                     
                     If TypeName(Item) = "MailItem" Then
                             
                             With CreateObject("VBSCRIPT.REGEXP")
                                 .Global = True
                                 .Pattern = "[\\/:*?|<>]"
                                 tmpSubject = .Replace(Item.Subject, "")
                             End With
                         
    '                     path = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\" & tmpSubject & ".msg"
    '                     Item.SaveAs (path)
                       
                PathStr = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\"
    NameStr = tmpSubject
    TypeStr = ".msg"
    
    i = 0
    FullPathStr = PathStr & NameStr & TypeStr
    If Dir(FullPathStr) = "" Then
    Item.SaveAs (FullPathStr)
    Else
        Do
          i = i + 1
          FullPathStr = PathStr & NameStr & "_" & i & TypeStr
          If Dir(FullPathStr) = "" Then Exit Do
        Loop
        Item.SaveAs (FullPathStr)
    End If
    
                      
                      End If
                 Next
             
    
    'Copy filename from folder to excel
            Dim olApp As Outlook.Application
            Set olApp = CreateObject("Outlook.Application")
            Dim ns As Outlook.Namespace
            Set ns = olApp.GetNamespace("MAPI")
            Dim mail As MailItem
            FolderPath = "C:\Users\DK-01\Desktop\Renaming\Quotation from SC\" '<<<<<<<<<<<<<<<<<<<
            MsgFile = Dir(FolderPath & "*.msg")
            i = 4
            Do While MsgFile <> ""
            Set itm = ns.OpenSharedItem(FolderPath & MsgFile)
            If TypeName(itm) = "MailItem" Then
            Set mail = itm
                    ActiveSheet.Cells(i, 1) = mail.Subject
                    ActiveSheet.Cells(i, 4) = mail.SenderEmailAddress
            i = i + 1
            End If
            MsgFile = Dir
            Loop
    
    End Sub

    Monday, December 4, 2017 4:01 AM