Option Explicit
'© 2006
Alla rättigheter XL-Dennis
Const
stPath
As String
=
"c:\Attachments\"
Const
EMBED_ATTACHMENT
As Long
=
1454
Const
RICHTEXT
As Long
=
1
Sub
Save_Remove_Attachments()
Dim
noSession
As Object
Dim
noDatabase
As Object
Dim
noView
As Object
Dim
noDocument
As Object
Dim
noNextDocument
As Object
'Inbäddade objekt är av datatypen variant vilket måste beaktas här.
Dim
vaItem
As Variant
Dim
vaAttachment
As Variant
'Instansiera Notes session.
Set
noSession =
CreateObject("Notes.NotesSession")
'Instansiera den berörda e-postdatabasen.
'(Här används en lokal e-postdatabas varför
ingen referens anges till en server.)
Set
noDatabase = noSession.GETDATABASE("",
"mail\xldennis.nsf")
'Mappar i Lotus Notes benämns som vyer och här
används Inbox.
Set
noView = noDatabase.GetView("($Inbox)")
'Hämta det första e-post i den definierade
vyn.
Set
noDocument = noView.GetFirstDocument
'Loopa igenom alla e-post i vyn InBox.
Do Until
noDocument
Is Nothing
'Fastän den följande ansatsen inte är nödvändig i detta exempel är det en
generell
'ansats som rekommenderas.
Set
noNextDocument = noView.GetNextDocument(noDocument)
'Kontrollera om e-post har bilaga eller ej.
If
noDocument.HasEmbedded
Then
Set
vaItem = noDocument.GetFirstItem("Body")
If
vaItem.Type = RICHTEXT
Then
For Each
vaAttachment In vaItem.EmbeddedObjects
If
vaAttachment.Type = EMBED_ATTACHMENT
Then
'Spara bilagan till den nya mappen på
hårddisken och ta bort bilagan från e-post.
With
vaAttachment
.ExtractFile stPath
&
vaAttachment.Name
.Remove
End With
'Spara det berörda e-post för att borttaget av bilaga ska verkställas.
'(En mer sofistikerad ansats kan övervägas om flera e-post har
flera bilagor för
'att undvika
en upprepande sparande av ett och samma e-post.)
noDocument.Save
True,
False
End If
Next
vaAttachment
End If
End If
Set
noDocument = noNextDocument
Loop
'Ta bort objekt fråm minnet.
Set
noNextDocument =
Nothing
Set
noDocument =
Nothing
Set
noView =
Nothing
Set
noDatabase =
Nothing
Set
noSession =
Nothing
MsgBox
"Alla bilagor har sparats och de tillhörande
e-post har blivit borttagna!",
_
vbInformation
End Sub