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.

18906
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!!