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_Attachments_Remove_Emails()
Dim
noSession
As Object
Dim
noDatabase
As Object
Dim
noView
As Object
Dim
noDocument
As Object
Dim
noRemoveDocument
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 sessionen.
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
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.
vaAttachment.ExtractFile
stPath
&
vaAttachment.Name
'Ange att e-post ska tas bort.
Set
noRemoveDocument
= noDocument
End If
Next
vaAttachment
End If
End If
Set
noDocument
= noNextDocument
'Ta bort e-post som har haft en eller flera
bilagor.
If Not
noRemoveDocument
Is Nothing Then
noRemoveDocument.Remove
(True)
Set
noRemoveDocument
=
Nothing
End If
Loop
'Ta bort objekt fråm minnet.
Set
noRemoveDocument
=
Nothing
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