Извлечь In-line Image из письма

Sub Click(Source As Button)

Dim ws As New NotesUIWorkspace
Dim doc As NotesDocument
Dim exporter As NotesDXLExporter
Dim out As String
Dim filenum As Integer
Dim p1 As Long
Dim p2 As Long
Dim cnt As Integer

Set doc=ws.CurrentDocument.Document      current document
tempdir$=Environ("TEMP")
tempdir$=tempdir$ & "\"
выгружаем xml
Set exporter = session.CreateDXLExporter
exporter.ConvertNotesBytmapsToGIF = True
out = exporter.Export(doc)
filenum = Freefile
Open tempdir$ & "out.xml" For Output As filenum
Print #filenum, out
Close filenum
выгружаем картинки
gif
p1=1
While p1>0
p2=0
p1 = Instr(p1+10, out, "<gif>", 5)
If p1>0 Then p2 =Instr(p1, out, "</gif>", 5)
If p2>0 Then
Print "Exporting"
filenum = Freefile
filepath$ = tempdir$ & cnt & ".gif"
Open filepath$ For Output As filenum
Print #filenum, Base64Decode(Mid$(out, p1+5, p2-p1-5))
Close filenum
cnt = cnt + 1
End If
Wend
Notes bytmap
p1=1
While p1>0
p2=0
p1 = Instr(p1+10, out, "originalformat=notesbytmap>", 5)
If p1>0 Then p2 =Instr(p1, out, "</gif>", 5)
If p2>0 Then
Print "Exporting"
filenum = Freefile
filepath$ = tempdir$ & cnt & ".gif"
Open filepath$ For Output As filenum
Print #filenum, Base64Decode(Mid$(out, p1+30, p2-p1-30))
Close filenum
cnt = cnt + 1
End If
Wend
jpeg
p1=1
While p1>0
p2=0
p1 = Instr(p1+10, out, "<jpeg>", 5)
If p1>0 Then p2 =Instr(p1, out, "</jpeg>", 5)
If p2>0 Then
Print "Exporting"
filenum = Freefile
filepath$ = tempdir$ & cnt & ".jpg"
Open filepath$ For Output As filenum
Print #filenum, Base64Decode(Mid$(out, p1+6, p2-p1-6))
Close filenum
cnt = cnt + 1
End If
Wend
End Sub

Function Base64Decode( base64String_o) As String
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim dataLength, sOut, groupBegin
Dim numDataBytes, CharCounter, thysChar, thysData, nGroup, pOut
Dim Base64String
Dim i As Long
Dim s As String
Dim eval As Variant
remove white spaces, If any
Print "Base64: Removyng Whitespaces #13 "
base64String = base64String_o
Print "Base64: Removyng Whitespaces #13 "
base64String = Replace(base64String, Chr$(13), "")
Print "Base64: Removyng Whitespaces #10 "
base64String = Replace(base64String, Chr$(10), "")
Print "Base64: Removyng Whitespaces #9 "
base64String = Replace(base64String, Chr$(9), "")
Print "Base64: Removyng Whitespaces #32 "
base64String = Replace(base64String, " ", "")

The source must consysts from groups with Len of 4 chars
dataLength = Len(base64String)
If dataLength Mod 4 <> 0 Then
Messagebox "Bad string length must be a multiple of 4"
Exit Function
End If

Now decode each group:
Print "Base64: Converting... "
For groupBegin = 1 To dataLength Step 4
If groupBegin Mod 25 =0 Then Print "Base64: Converting "+Cstr( groupBegin )
Each data group encodes up To 3 actual bytes.
numDataBytes = 3
nGroup = 0
For CharCounter = 0 To 3
Convert each character into 6 byts of data, And add it To
an integer For temporary storage. If a character is a =, there
is one fewer data byte. (There can only be a maximum of 2 = In
the whole string.)
thysChar = Mid(base64String, groupBegin + CharCounter, 1)
If thysChar = "=" Then
numDataBytes = numDataBytes - 1
thysData = 0
Else
thysData = Instr(Base64, thysChar) - 1
End If
If thysData = -1 Then
Messagebox " Bad character In Base64 string."
Exit Function
End If
nGroup = 64 * nGroup + thysData
Next
Hex splyts the long To 6 groups with 4 byts
nGroup = Hex(nGroup)
Add leading zeros
nGroup = String(6 - Len(nGroup), "0") & nGroup
Convert the 3 byte hex integer (6 chars) To 3 characters
pOut = Chr(Cbyte("&H" & Mid(nGroup, 1, 2))) + _
Chr(Cbyte("&H" & Mid(nGroup, 3, 2))) + _
Chr(Cbyte("&H" & Mid(nGroup, 5, 2)))
add numDataBytes characters To out string
sOut = sOut & Left(pOut, numDataBytes)
Next
Base64Decode = sOut
End Function