Another Outlook Attachments query: Rename extracted attachments to match email

[Lawboy1976]

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

[arnelgp]

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

[gmayor]

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

[arnelgp]

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

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

33645675

[Lawboy1976]

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