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