Consulting

Results 1 to 5 of 5

Thread: Another Outlook Attachments query: Rename extracted attachments to match email

  1. #1

    Another Outlook Attachments query: Rename extracted attachments to match email

    Hi all,

    Situation:
    Evening all. Lawyer-slash-code-dabbler here (mainly R these days, but started in VBA in Excel). Long story short, we have a file audit coming up. Historically, we have used paper files. Covid has inspired us to go digital, which is great, but it's going to have an impact on the audit: whereas previously I would just get the paper files, and scan them through our work printer to make a PDF, there are no papers now. Everything is stored on our case management software, which is great, but I need to extract all the attachments to all the emails (fine, see below), and, crucially, match the attachments tothe emails (not fine, why I'm asking for help). When i have got all of the emails and attachments sorted, I will convert them into PDFs and merge them. It is important that they are in the correct chronological order, and the attachments must be next to the originating emails.

    In a bit more detail:
    I was able to trawl our system so that I have a folder of, say, 300 .msg email files for each matter being audited (40 matters). The way that the system trawl worked is that the emails are numbered, with small numbers indicating earlier emails, and larger numbers indicating later documents. In that way they are chronological. The numbering system is based on the number of documents generated on our system as a whole: there are thousands of claims on our system, with documents being generated all the time, so the chances of any two emails on the same matter having sequential numbers, or even numbers within 100 of each other, are vanishingly small. All of the prefix numbers are 8 digits long.

    So, "33645675 - Email to Court.msg" might be from 1 June 2020 and "71456457 - Email to Solicitor.msg" might be from 2 August 2021. Now, let's say that both emails have an attachment:
    33645675 - Email to Court.msg has an attachment called "Consent order.pdf".
    71456457 - Email to Solicitor.msg has an attachment called "losses.xlsx".

    I am trying to alter a macro I found (below) so that it renames the extracted attachments to give it the 8 digit prefix from the .msg file name before the actual attachment name.
    So, attachment "Consent order.pdf" would be renamed to "33645675 Consent order.pdf", and because the 8 numbers at the front are the same, I'll know that the email and the PDF are a "pair".
    Otherwise, as the code below stands, I'm left with a PDF called "Consent order.pdf", and no idea which email it relates to, whereabouts in the combined PDF it should go, etc.
    To complete the example, "losses.xlsx" would be renamed to "71456457 losses.xlsx"

    So, this evening as a first step I've been looking for some code to extract attachments from a folder full of .msg files, and came across the code below, which I believe is one of Graham's. This is almost perfect for what I need, save the renaming aspect (and, as well as being beautifully simple to follow, will be massively time-saving in another day-to-day aspect of my work, so a million "thank you"s for the code as it stands).

    Stop waffling: Spell it out:
    I have tried altering the below so that the file name of the saved attachment matches the .msg file from which it came (mainly by trying to put something in place of att.FileName, such as msg.FileName). Whatever the trick is, it appears to be way outside my skills.
    I've looked at other threads, other boards, and read up on renaming in VBA, as well as reading other threads of setting the name so that it adds dat and time to the attachment name, etc, but that's not what I'm after. I've hit a deadend, and would really appreciate a hand, both to help with the audit and to further my understanding of VBA.

    Thank you for reading.


    Sub SaveOlAttachments()
    
    
    Dim msg As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strAttPath As String
    
    
        'path for creating msgs
    strFilePath = "C:\New\1\"
    
    
        'path for saving attachments
    strAttPath = "C:\New\2\"
    
    
    strFile = Dir(strFilePath & "*.msg")
    
    
    Do While Len(strFile) > 0
    
    
        Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
        
        If msg.Attachments.Count > 0 Then
             For Each att In msg.Attachments
                 att.SaveAsFile strAttPath & att.FileName
             Next
        End If
        
        strFile = Dir
        
    Loop
    
    
    End Sub

  2. #2
    not tested yet:
    Sub SaveOlAttachments()
    
    
    
    
        Dim msg As Outlook.MailItem
        Dim att As Outlook.Attachment
        Dim strFilePath As String
        Dim strAttPath As String
        'arnelgp
        Dim bolExists As Boolean
        Dim sNewFile As String
        
            'path for creating msgs
        strFilePath = "C:\New\1\"
        
        
            'path for saving attachments
        strAttPath = "C:\New\2\"
        
        '* create the folder
        Call ForceMkDir(strAttPath)
        
        strfile = Dir(strFilePath & "*.msg")
        
        
        Do While Len(strfile) > 0
        
        
            Set msg = Application.CreateItemFromTemplate(strFilePath & strfile)
            
            If msg.Attachments.Count > 0 Then
            
                
                 For Each att In msg.Attachments
                    ' arnelgp
                    ' do we need to overwrite if the file already exists on target folder?
                    ' currently, it will not and just go to next
                    ' attachment
                    '
                    'the "new" filename format:
                    '  [serial number] + [extension]
                    '
                    sNewFile = Val(strfile) & " " &  att.Filename
                    
                    With CreateObject("Scripting.FileSystemObject")
                        bolExists = .FileExists(strAttPath & sNewFile)
                    End With
                    If Not bolExists Then
                        ' arnelgp
                        att.SaveAsFile serialFile(strAttPath & sNewFile)
                        'att.SaveAsFile strAttPath & att.Filename
                    End If
                 Next
            End If
            
            strfile = Dir$
            
        Loop
    
    
    
    
    End Sub
    
    
    '******************************************
    '* arnelgp
    '*
    '* purpose:
    '*
    '* make a folder
    '*
    '******************************************
    Public Sub ForceMkDir(ByVal path As String)
        Dim var As Variant
        Dim i As Integer
        Dim s As String
        var = Split(path, "\")
        On Error Resume Next
        For i = 0 To UBound(var)
            s = s & var(i)
            VBA.MkDir s
            s = s & "\"
        Next
        Erase var
    End Sub
    '******************************************
    '* arnelgp
    '*
    '* purpose:
    '*
    '* get the file extension
    '*
    '******************************************
    Public Function getExt(ByVal path As String) As String
    Dim iX As Integer
    iX = InStrRev(path, ".")
    If Len(path) - iX < 5 Then
        getExt = Mid$(path, iX + 1)
    End If
    End Function
    '******************************************
    '* arnelgp
    '*
    '* purpose:
    '*
    '* make a serialized file
    '*
    '******************************************
    Public Function serialFile(ByVal fullpath As String) As String
        Dim Ext As String       'the file extension
        Dim file As String      'the filename
        Dim path As String      'the path
        Dim iX As Integer
        Dim sNew As String
        
        iX = InStrRev(fullpath, "\")
        file = Mid$(fullpath, iX + 1)
        path = Replace$(fullpath, file, "")
        iX = InStrRev(file, ".")
        If iX <> 0 Then
            Ext = Mid$(file, iX)
        End If
        file = Replace$(file, Ext, "")
        iX = 0
        sNew = path & file & Ext
        Do Until Len(Dir$(sNew)) = 0
            iX = iX + 1
            sNew = path & file & "(" & iX & ")" & Ext
        Loop
        serialFile = sNew
    End Function
    Last edited by arnelgp; 08-20-2021 at 10:42 PM.

  3. #3
    Based on your code, what I think you require is the following. Note that this will overwrite any existing file in strAttPath with the same name.
    Option Explicit
    
    Sub SaveOlAttachments()
    'Graham Mayor - https://www.gmayor.com - Last updated - 21 Aug 2021
    Dim msg As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strAttPath As String
    Dim sName As String, strFile As String
    
        'path for creating msgs
        strFilePath = "C:\New\1\"
    
        'path for saving attachments
        strAttPath = "C:\New\2\"
    
        strFile = Dir(strFilePath & "*.msg")
        If MsgBox("This could take a while. Please wait until completion message", vbInformation + vbOKCancel) = vbCancel Then Exit Sub
        Do While Len(strFile) > 0
            Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
            sName = GetNum(strFile) & " - "
            If msg.Attachments.Count > 0 Then
                For Each att In msg.Attachments
                    att.SaveAsFile strAttPath & sName & att.FileName
                Next att
            End If
            DoEvents
            strFile = Dir
        Loop
        MsgBox "Complete", vbInformation
    End Sub
    
    Private Function GetNum(sText As String) As String
    Dim i As Integer
        For i = 1 To Len(sText)
            If Mid(sText, i, 1) >= "0" And Mid(sText, i, 1) <= "9" Then
                GetNum = GetNum + Mid(sText, i, 1)
            End If
        Next
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  4. #4
    You only need to use Val().
    on immediate window:

    ?Val("33645675 - Email to Court.msg")

    33645675

  5. #5
    Wow. Just... wow.
    Thank you both. I've just tried Grahams, and am working through how GetNum acts. Love it.
    Really appreciate the assistance.

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
  •