Saving email attachments with VBA - code *nearly* working

[jamesgeorgewalker]

Not strictly Excel, but I guess you folks know VBA.

At work, I receive steel test certificates by email, and want to automate saving them onto my PC into folders based on the subject of the email, it uses a rule in Outlook to identify the email, then this code to save the attachement(s).

At the moment it is creating the folders on my PC, but not saving the files into them. The code runs without stopping, but doesn't have the desired outcome.

Here's the code:

Public Sub Test_Cert_Save(MItem As Outlook.MailItem)
Dim sSaveFolder As String
Dim sSubject As String
sSubject = MItem.Subject

sSaveFolder = "C:\Users\James\Downloads\Attachments\" & sSubject & "\"

'If Dir(sSaveFolder, vbDirectory) = "" Then
If Dir(sSaveFolder) = "" Then
sSaveFolder = "C:\Users\James\Downloads\Attachments\" & sSubject & "\"
Shell ("cmd /c mkdir """ & sSaveFolder & """")
For Each oAttachment In MItem.Attachments
MItem.Attachments.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next

'ElseIf Dir(sSaveFolder, vbDirectory) <> "" Then
ElseIf Dir(sSaveFolder) <> "" Then
sSaveFolder = "C:\Users\James\Downloads\Attachments\" & sSubject & "\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End If

End Sub


(I've removed some irrelevant bits which I'm sure are working)

Can anyone help me with making the code actually put the email attachment into the folder I've created?

Thanks

 

[John_w]

Try this:

Public Sub Test_Cert_Save(MItem As Outlook.MailItem)

    Dim sSaveFolder As String
    Dim sSubject As String
    Dim oAttachment As Outlook.Attachment
    
    sSubject = MItem.Subject
    
    sSaveFolder = "C:\Users\James\Downloads\Attachments\" & sSubject & "\"    
    If Dir(sSaveFolder, vbDirectory) = vbNullString Then
        Shell "cmd /c mkdir """ & sSaveFolder & """"
    End If
    
    For Each oAttachment In MItem.Attachments
        oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
    Next

End Sub

 

[jamesgeorgewalker]

Try this:

Public Sub Test_Cert_Save(MItem As Outlook.MailItem)

    Dim sSaveFolder As String
    Dim sSubject As String
    Dim oAttachment As Outlook.Attachment
   
    sSubject = MItem.Subject
   
    sSaveFolder = "C:\Users\James\Downloads\Attachments\" & sSubject & "\"   
    If Dir(sSaveFolder, vbDirectory) = vbNullString Then
        Shell "cmd /c mkdir """ & sSaveFolder & """"
    End If
   
    For Each oAttachment In MItem.Attachments
        oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
    Next

End Sub

Brilliant, that worked!

I was so close :/

Thanks for your help - I really wish I was better at VBA, would make many thing easier

 

[jamesgeorgewalker]

Try this:

Public Sub Test_Cert_Save(MItem As Outlook.MailItem)

    Dim sSaveFolder As String
    Dim sSubject As String
    Dim oAttachment As Outlook.Attachment
   
    sSubject = MItem.Subject
   
    sSaveFolder = "C:\Users\James\Downloads\Attachments\" & sSubject & "\"   
    If Dir(sSaveFolder, vbDirectory) = vbNullString Then
        Shell "cmd /c mkdir """ & sSaveFolder & """"
    End If
   
    For Each oAttachment In MItem.Attachments
        oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
    Next

End Sub

I spoke too soon

not working today... hard to understand why it worked for one email and not another

 

[John_w]

I would set a breakpoint (F9) on sSubject = MItem.Subject and step through the code (F8) and check that oAttachment.DisplayName is correct and not blank.

 

[jamesgeorgewalker]

I would set a breakpoint (F9) on sSubject = MItem.Subject and step through the code (F8) and check that oAttachment.DisplayName is correct and not blank.

brilliant, thanks!

It's years since I was taught VBA basics and had completely forgotten about break points, that should help massively

 

[jamesgeorgewalker]

I would set a breakpoint (F9) on sSubject = MItem.Subject and step through the code (F8) and check that oAttachment.DisplayName is correct and not blank.

I've now identified a theme, but not a cause....

The first email of the day saves the attachments correctly, for subsequent emails folders are created but the attachment is not saved.

I can't understand why - any suggestions?

It would suggest an issue with the 'for each' line, but I can't think what would cause this.

Any help gratefully received

 

[John_w]

In the absence of any errors it's difficult to say why the attachments aren't being saved.

One possibility is a timing issue whereby the Shell function has not finished creating the destination folder by the time the SaveAsFile line is being executed. The reason is that VBA Shell is asynchronous, meaning the process which runs the mkdir command is separate from Excel and VBA doesn't wait for the command to complete but executes the next line immediately. But if the destination folder doesn't exist I would expect an error to occur.

Instead of VBA Shell, we can use Windows Script Shell to run the mkdir command and wait until the command has completed before executing the next line.

Replace:

        Shell "cmd /c mkdir """ & sSaveFolder & """"

with:

        CreateObject("WScript.Shell").Run "cmd /c mkdir """ & sSaveFolder & """", 0, True