MarcNFM
10-24-2011, 11:12 AM
I have implemented the code at the bottom of this post. It saves and strips attachments from the message. I wanted to change the SaveAs portion to include a unique identifier like a date stamp in the file name. This way files with the same name would not overwrite older versions. I have been trying to integrate either of these two methods w/o success
1)EntryID, FileName = "C:\Email Attachments\" & Item.EntryID & Atmt.FileName
2)CreationTime, FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Full code is below w/o alterations. Does anyone have a suggestion on how to best alter the code?
Much Thanks!
Public Sub StripAttachments()
Dim ilocation As String
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim result
'Put in the folder location you want to save attachments to
ilocation = "U:\mhuntsman\Removed Attachs\" ' CSIDL_U:\mhuntsman As Long = &H5"
On Error Resume Next
result = MsgBox("Do you want to remove attachments from selected email(s)?", vbYesNo + vbQuestion)
If result = vbNo Then
Exit Sub
End If
' Instantiate an Outlook Application object.
' Set objOL = CreateObject("Outlook.Application")
Set objOL = Application
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Check each selected item for attachments.
' If attachments exist, save them to the Temp
' folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
If objMsg.Class = olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for
' removing items from a collection. Otherwise,
' the loop counter gets confused and only every
' other item is removed.
strFile = ""
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
Dim strHTML As String
strHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachments.Item(i).FileName & Chr(34) & ">" & objAttachments.Item(i).FileName & "</a><br>" & vbCrLf
strFile = strFile & strHTML
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile (ilocation & objAttachments.Item(i))
' Save the attachment as a file.
objAttachments.Item(i).Delete
Next i
strFile = "Attachment removed from the message and backup-ed to[<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
Dim objDoc As Object
Dim objInsp As Outlook.Inspector
Set objInsp = objMsg.GetInspector
Set objDoc = objInsp.WordEditor
objDoc.Characters(1).InsertBefore strFile
objMsg.HTMLBody = strFile + objMsg.HTMLBody
Set objInsp = Nothing
Set objDoc = Nothing
End If
strFile = strFile & vbCrLf & vbCrLf
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
1)EntryID, FileName = "C:\Email Attachments\" & Item.EntryID & Atmt.FileName
2)CreationTime, FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Full code is below w/o alterations. Does anyone have a suggestion on how to best alter the code?
Much Thanks!
Public Sub StripAttachments()
Dim ilocation As String
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim result
'Put in the folder location you want to save attachments to
ilocation = "U:\mhuntsman\Removed Attachs\" ' CSIDL_U:\mhuntsman As Long = &H5"
On Error Resume Next
result = MsgBox("Do you want to remove attachments from selected email(s)?", vbYesNo + vbQuestion)
If result = vbNo Then
Exit Sub
End If
' Instantiate an Outlook Application object.
' Set objOL = CreateObject("Outlook.Application")
Set objOL = Application
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Check each selected item for attachments.
' If attachments exist, save them to the Temp
' folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
If objMsg.Class = olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for
' removing items from a collection. Otherwise,
' the loop counter gets confused and only every
' other item is removed.
strFile = ""
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
Dim strHTML As String
strHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachments.Item(i).FileName & Chr(34) & ">" & objAttachments.Item(i).FileName & "</a><br>" & vbCrLf
strFile = strFile & strHTML
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile (ilocation & objAttachments.Item(i))
' Save the attachment as a file.
objAttachments.Item(i).Delete
Next i
strFile = "Attachment removed from the message and backup-ed to[<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
Dim objDoc As Object
Dim objInsp As Outlook.Inspector
Set objInsp = objMsg.GetInspector
Set objDoc = objInsp.WordEditor
objDoc.Characters(1).InsertBefore strFile
objMsg.HTMLBody = strFile + objMsg.HTMLBody
Set objInsp = Nothing
Set objDoc = Nothing
End If
strFile = strFile & vbCrLf & vbCrLf
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub