Detach Mail Attachments To Hard Drive

This code can be useful to administrators, but I have designed it for end
users. Place this on an action button in the users inbox, and it will easily
allow the user to detach the mail attachment(s) to a directory below the mail
file. For instance if the mail file ("d:\notes\data\mail\juser.nsf") contains
an attachment named filename.txt, then the attachment will be detached to
"d:\notes\data\mail\attachments\filename.txt" The code will also stamp the
email with a location of the attachment. Minimal modifications will allow you
to place this code in multiple areas.

This will help you with your users with 1 GIG mail files, by making it easy and
consistent to detach the files.
Sub Click(Source As Button)
Dim session As New NotesSession
Dim doc As NotesDocument
Dim rtitem As Variant
Dim filename As String
Dim filepath As String
Dim fnlen As Integer
Dim fplen As Integer
Dim error53 As Variant
Dim error4005 As Variant
Dim attr As Integer

Const ErrFileNotFound = 53
Const ErrCannotCreateFile = 4005

On Error Goto ErrHandle
On Error ErrFileNotFound Goto ErrHandle53
On Error ErrCannotCreateFile Goto ErrHandle4005

fnlen = Len( session.CurrentDatabase.FileName )
fplen = Len( session.CurrentDatabase.FilePath )
filepath = Mid$( session.CurrentDatabase.FilePath, 1, fplen - fnlen) &

Set doc = session.DocumentContext

If doc Is Nothing Then Exit Sub

Set rtitem = doc.GetFirstItem( "Body" )

If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects

If ( o.Type = EMBED_ATTACHMENT ) Then
filename = o.Source
error53 = False
error4005 = False
attr = Getattr ( filepath & filename ) 'Will error to
53 if file does not exist
If error53 Then
Call o.ExtractFile( filepath & filename )
error53 = False
filename = Inputbox$ ( "Please enter a new file name,
" & filename & " already exists.", "File Already Exists", "new" & filename )
If filename = "" Then Exit Sub
attr = Getattr ( filepath & filename ) 'Will error
to 53 if file does not exist

If error53 Then
Call o.ExtractFile( filepath & filename )
Msgbox "Unable to complete request, file already
Exit Sub
End If
End If

If error4005 Then Call o.ExtractFile( filepath & filename )

Call rtitem.AddNewLine( 1 )
Call rtitem.AppendText("[file: " & filename & " detached
to: " & filepath & filename & "]")

Call o.Remove
Call doc.Save( False, True )

End If
End Forall
End If
Exit Sub

' This is file not found, good error, meaning this filename does not already
error53 = True
Resume Next

' directory does not exist so we will create it...
If error4005 Then
'second time through - fatal error - can't really imagine this
Msgbox "Unable to complete request, directory does not exist."
Exit Sub
'first time through - make the directory if possible
Mkdir filepath
error4005 = True
End If
Resume Next

Messagebox "Error" & Str(Err) & ": " & Error$
Exit Sub

End Sub

This was first published in November 2000

There are Comments. Add yours.

TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

Disclaimer: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.