Remove attachments from multiple mail messages

• Duncan Caldwell
• Published: 16 Oct 2002

View member feedback to this tip.

This script allows you to remove the attachments from a selection of documents. For each attachment you get the option to select the location and file name of the attachment. It will default to the location of the last attachment saved and with the same file name as the attachment. If you manually type in the path or file name it will check to see that the path exists and that there are no duplicate file names.

Place this script in an agent set to run from the Agent List on selected documents. This agent can then be called from an Action button in a view to remove all attachments from the selected documents.

Option Public

Dim session As  NotesSession 
Dim path As String
Dim separator As String


Sub Initialize 
 
 Dim Workspace As New NotesUIWorkspace
 Dim db As NotesDatabase 
 Dim collection As NotesDocumentCollection 
 Dim doc As NotesDocument 
 Dim rtitem As Variant 
 Dim filename As String 
 Dim strSaveName As String 
 Dim strSavePath As String 
 Dim dname As String 
 Dim pname As String 
 Dim num As Integer 
 Dim subname As String 
 Dim subext As String 
 Dim position As String 
 Dim subposition As String 
 Dim dec As String 
 Dim message$ 
 
 Set session = New notesSession
 Dim richstyle As NotesRichTextStyle 
 Set richstyle = session.CreateRichTextStyle 
 richstyle.NotesColor = COLOR_BLUE 
 
 Set db = session.CurrentDatabase
 Set collection = db.UnprocessedDocuments 
 Lastpath = Session.GetEnvironmentString( "FileDlgDirectory" , True )
 
 Set doc = collection.GetFirstDocument 
 Call SetPlatform
 
 While Not( doc Is Nothing )
  If doc.HasEmbedded Then
   Set rtitem = doc.getfirstitem("Body")
   If (rtitem.type = RICHTEXT) Then
    Forall object In rtitem.EmbeddedObjects
     If (object.Type = EMBED_ATTACHMENT) Then
      filename = object.source
      Do 
       'Get the file name and path.
       'Loop until there is either a valid name or the user cancels from the filesave dialog
       filepath = Workspace.SaveFileDialog( False , "Save attachment." ,"" , Lastpath , filename )
       If Not(Isempty(filepath)) Then
        flag = checkpath( filepath(0) )
        Select Case flag 
        Case 0
         'All OK to save File
        Case 1
         'Path was not created
         Call Workspace.Prompt( PROMPT_OK, "Error", "Path was not created!" )
        Case  2
         'Duplicate file found
         flag2 = Workspace.Prompt( PROMPT_YESNO, "Alert", "Replace existing file?" )
         If Flag2 = 1 Then Flag = 0
        End Select
       Else
        flag = 2
       End If
      Loop Until Flag < 2 Or Isempty(filepath)
      If flag = 0 Then
       'If The path and file name are OK then save the file and remove it.
       Call object.extractfile(filepath(0))       
       Call object.remove
       Call rtitem.AddNewLine( 2 ) 
       Call rtitem.AppendStyle(richstyle) 
       Call rtitem.AppendText( "An attachment has been Removed from this document and Saved to --> " & filepath(0) ) 
       Call doc.Save( False, True , True ) 
       'Reset the environment variable to the last locatation a file was saved.
       LastPath = Path
       Call Session.SetEnvironmentVar( "FileDlgDirectory", LastPath  , True )
      End If
     End If
    End Forall
   End If
  End If
  Set doc = collection.GetNextDocument( doc ) 
 Wend
 
End Sub
Function checkpath( filepath As String )
 'Check to see if the Directory and file name exist
 'If the directory does not exist do you want to create it.
 
 strStart = 1
 strFound = 1
 path = ""
 filename = ""
 CreatePath = False
 checkpath = 0
 
 While strFound > 0
  'Look for the path delimiter
  strFound = Instr(strStart , filepath , separator )
  If strFound > 0 Then 
   path = Left( FilePath , strFound )
   DoesPathExist = Dir$( path , 16 )
   If DoesPathExist = ""  Then 
    If CreatePath = False Then
     YesNo = Messagebox( "Create Path ? " , 4 , "Path does not exist !")
    End If
    If YesNo = 6 Then
     Mkdir path
     CreatePath = True
    Else
     CheckPath = 1
    End If
   End If
   strStart = strFound + 1
  End If 
 Wend
 
 If strFound >= 0 Then
  filename = Mid$( filepath , strStart )
  'Check to see if the file name exists
  DoesFileExist = Dir$( filepath , 0 )
  If DoesFileExist <> "" Then CheckPath = 2
 Else
  Checkpath = 1
 End If
 
End Function

Sub SetPlatform
 'Set the directory separator based on platform
 'Only Mac and Win32 formats are supported
 path = session.GetEnvironmentValue( "FileDlgDirectory" , True )
 If path = "" Then
  path = session.GetEnvironmentValue( "Directory" , True )
 End If
 separator = ""
 If session.platform = "Macintosh" Then
  strFound = -1
  separator = ":"
 End If
End Sub

MEMBER FEEDBACK TO THIS TIP

When implementing this tip, I found that the code presented contains two minor bugs:

1. No path separator for the W32 platform was supplied
2. Upon clicking "No" when prompted to replace an existing file, the code did not move on to the next attachment but rather returned to the attachment being processed.

Option Public





Dim session As  NotesSession 
Dim path As String
Dim separator As String

Sub Initialize 
 
 Dim Workspace As New NotesUIWorkspace
 Dim db As NotesDatabase 
 Dim collection As NotesDocumentCollection 
 Dim doc As NotesDocument 
 Dim rtitem As Variant 
 Dim filename As String 
 Dim strSaveName As String 
 Dim strSavePath As String 
 Dim dname As String 
 Dim pname As String 
 Dim num As Integer 
 Dim subname As String 
 Dim subext As String 
 Dim position As String 
 Dim subposition As String 
 Dim dec As String 
 Dim message$ 
 
 Set session = New notesSession
 Dim richstyle As NotesRichTextStyle 
 Set richstyle = session.CreateRichTextStyle 
 richstyle.NotesColor = COLOR_BLUE 
 
 Set db = session.CurrentDatabase
 Set collection = db.UnprocessedDocuments 
 Lastpath = Session.GetEnvironmentString( "FileDlgDirectory" , True )
 
 Set doc = collection.GetFirstDocument 
 Call SetPlatform
 
 While Not( doc Is Nothing )
  If doc.HasEmbedded Then
   Set rtitem = doc.getfirstitem("Body")
   If (rtitem.type = RICHTEXT) Then
    Forall object In rtitem.EmbeddedObjects
     If (object.Type = EMBED_ATTACHMENT) Then
      filename = object.source
      Do 
       'Get the file name and path.
       'Loop until there is either a valid name or the user cancels from the filesave dialog
       filepath = Workspace.SaveFileDialog( False , "Save attachment." ,"" , Lastpath , filename )
       If Not(Isempty(filepath)) Then
        flag = checkpath( filepath(0) )
        Select Case flag 
        Case 0
         'All OK to save File
        Case 1
         'Path was not created
         Call 
Workspace.Prompt( PROMPT_OK, "Error", "Path was not created!" )
        Case  2
         'Duplicate file found
         flag2 = 
Workspace.Prompt( PROMPT_YESNO, "Alert", "Replace existing file?" )
         If Flag2 = 1 Then
          Flag = 0
         Else 'addition 
08/27/2003 to prevent infinite loop with same attachment
          Flag = 1
         End If
        End Select
       Else
        flag = 2
       End If
      Loop Until Flag < 2 Or Isempty(filepath)
      If flag = 0 Then
       'If The path and file name are OK then save the file and remove it.
       Call object.extractfile(filepath(0))       
      End If 'change 08/27/2003 moved up end if 
to this point to allow object removal for attachments related to existing files user 
chose to NOT replace
      Call object.remove
      Call rtitem.AddNewLine( 2 ) 
      Call rtitem.AppendStyle(richstyle) 
      Call rtitem.AppendText( "An attachment has 
been Removed from this document and Saved to --> " & filepath(0) ) 
      Call doc.Save( False, True , True ) 
       'Reset the environment variable to the last locatation a file was saved.
      LastPath = Path
      Call Session.SetEnvironmentVar( 
"FileDlgDirectory", LastPath  , True )
     End If
    End Forall
   End If
  End If
  Set doc = collection.GetNextDocument( doc ) 
 Wend
 
End Sub
Function checkpath( filepath As String )
 'Check to see if the Directory and file name exist
 'If the directory does not exist do you want to create it.
 
 strStart = 1
 strFound = 1
 path = ""
 filename = ""
 CreatePath = False
 checkpath = 0
 
 While strFound > 0
  'Look for the path delimiter
  strFound = Instr(strStart , filepath , separator )
  If strFound > 0 Then 
   path = Left( FilePath , strFound )
   DoesPathExist = Dir$( path , 16 )
   If DoesPathExist = ""  Then 
    If CreatePath = False Then
     YesNo = Messagebox( "Create Path ? " , 4 , "Path 
does not exist !")
    End If
    If YesNo = 6 Then
     Mkdir path
     CreatePath = True
    Else
     CheckPath = 1
    End If
   End If
   strStart = strFound + 1
  End If 
 Wend
 
 If strFound >= 0 Then
  filename = Mid$( filepath , strStart )
  'Check to see if the file name exists
  DoesFileExist = Dir$( filepath , 0 )
  If DoesFileExist <> "" Then CheckPath = 2
 Else
  Checkpath = 1
 End If
 
End Function
Sub SetPlatform
 'Set the directory separator based on platform
 'Only Mac and Win32 formats are supported
 path = session.GetEnvironmentValue( "FileDlgDirectory" , True )
 If path = "" Then
  path = session.GetEnvironmentValue( "Directory" , True )
 End If
 separator = ""
 If session.platform = "Macintosh" Then
  strFound = -1
  separator = ":"
 Else 'addition 08/27/2003 to support W32 platform
  separator = "\"
 End If
End Sub

Do you have comments of your own? Let us know.