Sub SaveSelected() 'Declaration Dim myItems, myItem, myAttachments, myAttachment Dim myOrt As String Dim myOLApp As New Outlook.Application Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim objFSO As Object Dim intCount As Integer 'Ask for destination folder 'myOrt = "\\file4\\shared\\itarf\\" myOrt = "C:\\temp\\" 'On Error Resume Next Set objFSO = CreateObject("Scripting.FileSystemObject") 'work on selected items Set myOlExp = myOLApp.ActiveExplorer Set myOlSel = myOlExp.Selection 'for all items do... For Each myItem In myOlSel 'point on attachments Set myAttachments = myItem.Attachments 'if there are some... If myAttachments.Count > 0 Then 'add remark to message text myItem.Body = myItem.Body & vbCrLf & _ "E-mail Attachment(s): Automatically Saved to Location Below" & vbCrLf 'for all attachments do... For i = 1 To myAttachments.Count strFileName = myAttachments(i).DisplayName strPriorFileName = strFileName intCount = 1 Do While True strFileName = InputBox("Type in the name to save the ITARF as. Please use the <last name>,<first name>_<year><month><date>.??? format.", "Save Attachments", strFileName) If objFSO.FileExists(myOrt & strFileName) Then strFileName = objFSO.GetBaseName(myOrt & strFileName) & "(" & intCount & ")." & objFSO.GetExtensionName(myOrt & strFileName) intCount = intCount + 1 Else myAttachments(i).SaveAsFile myOrt & strFileName Exit Do End If Loop 'add name and destination to message text myItem.Body = myItem.Body & "File: " & strPriorFileName & " saved as " & myOrt & strFileName & vbCrLf Next i 'for all attachments do... While myAttachments.Count > 0 myAttachments(1).Delete Wend 'save item without attachments myItem.Save End If Next 'free variables Set myItems = Nothing Set myItem = Nothing Set myAttachments = Nothing Set myAttachment = Nothing Set myOLApp = Nothing Set myOlExp = Nothing Set myOlSel = Nothing End Sub
var
This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)