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
______________________