This is what I want to do. I have a script that I put together from your site
and others that strips attachments from e-mails, and puts a small text
attachment in the e-mail that has the name of the file that was attached.
Right now, I must highlight the messages I want to process this way. I would
like to adjust this script so that it automatically does this procedure for
any e-mail message I send with an attachment, and then saves the processed
message in the Sent folder. Here is the entire script:
______________________
Public Sub StripAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
'added
Dim objItem As Object
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim strS As String
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.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.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).PathName &
objAttachments.Item(i).FileName
' Write to file
strS = "Removed Attachments: " & vbCrLf & "'" &
objAttachments.Item(i).PathName & objAttachments.Item(i).FileName & "'"
' & vbCrLf & vbCrLf & vbCrLf & objMsg.Body
WriteToFile strS, "J:\My Documents\Attach.txt", True
' add remark to message text
' objMsg.Body = "Removed Attachments: " & vbCrLf & "'"
& objAttachments.Item(i).PathName & objAttachments.Item(i).FileName & "'" &
vbCrLf & vbCrLf & vbCrLf & objMsg.Body
' Delete the attachment.
objAttachments.Item(i).Delete
'AddAttachmentToSelectedMessages
objMsg.Attachments.Add ("J:\My Documents\Attach.txt")
objMsg.Save
Next i
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Function WriteToFile(Var As Variant, _
FileSpec As String, _
Optional Overwrite As Long = True) _
As Long
'Writes Var to a textfile as a string.
'Returns 0 if successful, an errorcode if not.
'Overwrite argument controls what happens
'if the target file already exists:
' -1 or True (default): overwrite it.
' 0 or False: append to it
' Any other value: abort.
Dim lngFN As Long
On Error GoTo Err_WriteToFile
lngFN = FreeFile()
'Change Output in next line to Append to
'append to existing file instead of overwriting
Select Case Overwrite
Case True
Open FileSpec For Output As #lngFN
Case False
Open FileSpec For Append As #lngFN
Case Else
If Len(Dir(FileSpec)) > 0 Then
Err.Raise 58 'File already exists
Else
Open FileSpec For Output As #lngFN
End If
End Select
Print #lngFN, CStr(Var);
Close #lngFN
WriteToFile = 0
Exit Function
Err_WriteToFile:
WriteToFile = Err.Number
End Function
______________________
