Thanks again, gmayor. You started me off on the road of VBA for Outlook. Below is my first effort (admittedly 60% your code, 20% of skattoni's and 20% of mine). For anyone interested, this macro will loop through all items selected in the explorer window. If it finds a pdf attachment it saves it to c:\Test, likewise if it finds a message as an attachment it looks for pdf attachments in those too and saves them to the same place if it finds any. It also checks (credit to a previous post by gmayor) for duplicate filenames and renames any duplicate names ...(1), ...(2), etc in the destination folder:
Option Explicit
Sub msgAsAttachment() ' v1.1
Dim CurrItem As MailItem
Dim attSub As Attachment
Dim msgInternal As MailItem
Dim attInternal As Attachment
Dim tempFileName As String
Dim tempFolder As String
Dim intMessage As Integer
Dim intAttachment As Integer
Dim attCurrent As Attachment
Dim strAttachFName As String
tempFolder = "C:\Test\"
tempFileName = "dummy.msg"
For Each CurrItem In ActiveExplorer.Selection ' The item selected on the explorer (i - index number if several)
For intAttachment = 1 To CurrItem.Attachments.Count
Set attCurrent = CurrItem.Attachments(intAttachment)
If Right(attCurrent, 3) = "pdf" Then
strAttachFName = FileNameUnique("C:\Test\", attCurrent.FileName, Right(attCurrent, 3))
attCurrent.SaveAsFile tempFolder & strAttachFName
ElseIf Right(attCurrent.FileName, 3) = "msg" Then
attCurrent.SaveAsFile tempFolder & tempFileName
Set msgInternal = CreateItemFromTemplate(tempFolder & tempFileName)
For Each attSub In msgInternal.Attachments
If Right(attSub, 3) = "pdf" Then
strAttachFName = FileNameUnique("C:\Test\", attSub.FileName, Right(attSub, 3))
attCurrent.SaveAsFile tempFolder & strAttachFName
End If
Next
msgInternal.Delete
End If
Next
Next
Set msgInternal = Nothing
Set CurrItem = Nothing
Kill tempFolder & tempFileName
End Sub
Private Function FileNameUnique(strPath As String, strFileName As String, strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Great stuff, thanks again both of you!
Reply With Quote
