Outlook VBA, save selected attachment to folder on HDD

[WillemKanon]

Hi,

I want to create a button in Outlook to save a selected attachment to a specific folder.
We receive several files in one e-mail and they all have a specific location on our network.
For example we receive drwaings and orders in the same e-mail.

I've searched for some kind of macro but I couldn't find one that fits my needs.
this is my current code, but there are a few points that does not work for me

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
    dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd")
saveFolder = "C:\Temp\"
     For Each objAtt In itm.Attachments
          If InStr(objAtt.DisplayName, ".pdf") Then
            objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName & " " & dateFormat
          End If
     Next
End Sub

1) I can't activate this code through a button (this is automatic script based on a rule)
2) This code saves all PDF files instead of only the selected ones
3) I use the date to prevent overwriting, but I prefer it if the file only gets an extension when the filename already exists

can someone please help me?

[gmayor]

The following is as close to your code as required to do the job, however it will fall apart if the folder does not exist and if there is more than one attachment with the same name the later one will overwrite the earlier one. If that is not a problem then

Public Sub saveAttachtoDisk()
Dim objAtt As Outlook.Attachment
Dim olMsg As Outlook.MailItem
Dim strDate As String
Dim strName As String
Const saveFolder As String = "C:\Temp\"
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    strDate = Format(olMsg.ReceivedTime, " yyyy-mm-dd")
    For Each objAtt In olMsg.Attachments
        If InStr(objAtt.fileName, ".pdf") > 0 Then
            strName = Left(objAtt.fileName, (InStrRev(objAtt.fileName, Chr(46))) - 1) & strDate & ".pdf"
            objAtt.SaveAsFile saveFolder & strName
        End If
    Next objAtt
lbl_Exit:
    Set objAtt = Nothing
    Set olMsg = Nothing
    Exit Sub
End Sub

If it is a problem, I have posted code elsewhere in this forum that demonstrates how to handle missing folders and duplicate names.

[WillemKanon]

Hi Graham,

thnx for your help!
but the code still doesn't save only the selected attachment.
alle the attachements in the e-mail are saved to the folder, I just want to save the selection of attachments. (so 1 out of 3 or 2 out of 3)

hope you can help me with that

[gmayor]

I suppose you could add a prompt (see below)

Public Sub saveAttachToDisk()
Dim objAtt As Outlook.Attachment
Dim olMsg As Outlook.MailItem
Dim strDate As String
Dim strName As String
Dim lngAns As Long
Const saveFolder As String = "C:\Temp\"
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    strDate = Format(olMsg.ReceivedTime, " yyyy-mm-dd")
    For Each objAtt In olMsg.Attachments
        If InStr(objAtt.fileName, ".pdf") > 0 Then
            lngAns = MsgBox("Save file " & vbCr & objAtt.fileName & "?", vbYesNo)
            If lngAns = vbYes Then
                strName = Left(objAtt.fileName, (InStrRev(objAtt.fileName, Chr(46))) - 1) & strDate & ".pdf"
                objAtt.SaveAsFile saveFolder & strName
            End If
        End If
    Next objAtt
lbl_Exit:
    Set objAtt = Nothing
    Set olMsg = Nothing
    Exit Sub

[WillemKanon]

thnx this helps a lot

now I see a better opportunity
because in the e-mail there can be 3 types of attachments; orders, drawings and other attachments
is it possible to give a message box with the options 'order' 'drawing' and 'dont save'?

when you click on order the file will be saved in specific folder for orders
when you click on drawing the file will be saved in specific folder based on the senders adress extension (e.g. gmail.com)

[gmayor]

Perhaps you would tell us what your end game is rather than keep drip-feeding changed requirements.

The best way to handle your latest request is to create a userform with three radio buttons, one for each option, a text box for the filename and two command buttons.

Userform1.jpg
The code for the userform would be

Option Explicit

Private Sub CommandButton1_Click()
    Hide
    Tag = 1
End Sub


Private Sub CommandButton2_Click()
    Hide
    Tag = 0
End Sub

The main code would be as follows - note the two paths.

Option Explicit

Public Sub saveAttachToDisk()

Dim objAtt As Outlook.Attachment
Dim olMsg As Outlook.MailItem
Dim strDate As String
Dim strName As String
Dim lngAns As Long
Dim oFrm As UserForm1
Const saveFolder1 As String = "C:\Temp\Orders\"
Const saveFolder2 As String = "C:\Temp\Drawings\"


    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    strDate = Format(olMsg.ReceivedTime, " yyyy-mm-dd")
    For Each objAtt In olMsg.Attachments
        If InStr(objAtt.fileName, ".pdf") > 0 Then
            Set oFrm = New UserForm1
            With oFrm
                .Caption = "Select Save Option"
                .CommandButton1.Caption = "Continue"
                .CommandButton2.Caption = "Cancel"
                .TextBox1.Text = objAtt.fileName
                .OptionButton1.Caption = "Orders"
                .OptionButton2.Caption = "Drawings"
                .OptionButton3.Caption = "Don't save"
                .OptionButton3.Value = True
                .Show
                If .Tag = 0 Then GoTo lbl_Exit
                strName = Left(objAtt.fileName, (InStrRev(objAtt.fileName, Chr(46))) - 1) & strDate & ".pdf"
                Select Case True
                    Case Is = .OptionButton1.Value
                        objAtt.SaveAsFile saveFolder1 & strName
                    Case Is = .OptionButton2.Value
                        objAtt.SaveAsFile saveFolder2 & strName
                    Case Else
                End Select
            End With
            Unload oFrm
        End If
    Next objAtt
lbl_Exit:
    Set oFrm = Nothing
    Set objAtt = Nothing
    Set olMsg = Nothing
    Exit Sub
End Sub

[WillemKanon]

I'm sorry if I'm drip-feeding, but I just don't know all the possibilities in VBA yet.
my end game is the fastest and most easy way to save the 2 kind of documents we receive in this particular mailbox and ignore the other files.

I first hoped it could be fully automatic but that's not possible because there are to many variables.

I think that the solution you just presented is the most perfect we can get within our proces and with the little knowledge I have about programming

Thank you very much for your help!!