Saving pictures from notes document to disk

HCL Domino Domino Forum
1

Hi,

I’m tring to save pictures from document to jpg files - below is the code I’m using to do it.

The problem is that jpg files are “empty” (1kB and nothing in graphic viewer). Running the code generates no error, picNode.NodeValue returns value and Decode64Java returns value too.

What is wrong with this code? Please, help me!

Konrad

Option Public

Uselsx “*javacon”

Sub Initialize

Dim s As New NotesSession

Dim db As NotesDatabase

Dim doc As NotesDocument

Set db = s.CurrentDatabase



Set doc = db.UnprocessedDocuments.GetFirstDocument()



Dim stream As NotesStream

Set stream = s.CreateStream



Call stream.Truncate

Dim exporter As NotesDXLExporter

Set exporter = s.CreateDXLExporter

exporter.ConvertNotesBitmapsToGIF = True



Call exporter.SetInput(doc)

Call exporter.SetOutput(stream)

Call exporter.Process



' domParser

Dim domParser As NotesDOMParser

Dim docNode As NotesDOMDocumentNode

Dim picNode As NotesDOMTExtNode

Dim docList As NotesDOMNodeList



Set domParser=s.CreateDOMParser( stream )

domParser.Process



 'get the document node

Set docNode = domParser.Document



Set docList = docNode.GetElementsByTagName ("picture")

If docList.NumberOfEntries = 0 Then  Exit Sub



For i = 1 To docList.NumberOfEntries

	Set picNode = docList.GetItem(i).FirstChild.FirstChild

	

	Set stream = s.CreateStream

	stream.Open("E:\" + Cstr(i) + ".jpg")

	

	Call stream.WriteText(Decode64Java(picNode.NodeValue))

	Call stream.Close	

Next i

End Sub

Function Decode64Java(d$) As String

Dim jsession As New JavaSession

Dim B As Variant

B = jsession.GetClass("sun/misc/BASE64Decoder") .CreateObject().decodeBuffer(d$)



r$ = ""

For i% = 14 + B(6) To Ubound(B)

	r$ = r$ & Chr$(B(i%))

Next

DecodeJava = r$

End Function

2

Subject: Saving pictures from notes document to disk

Well, one problem is that you are saving GIFs with a .JPG file extension. (“ConvertNotesBitmapsToGIF” creates GIFs, not JPEGs.)

3

Subject: *You are just SO picky

4

Subject: RE: Saving pictures from notes document to disk

Thanks, but I tried ConvertNotesBitmapsToGIF=True/False and saving to GIF and JPG and nothing helps. Another suggestions?

Konrad

5

Subject:

I found solution of my problem. I found some code sources in internet and I modified my previous code - now it seems to work.

Konrad

Sub Initialize

Dim s As New NotesSession

Dim doc As NotesDocument

Dim db As NotesDatabase

Set db = s.CurrentDatabase



Set doc = db.UnprocessedDocuments.GetFirstDocument()



Call SaveDocumentPicturesToDisk (doc, "E:")

End Sub

Sub SaveDocumentPicturesToDisk (d As NotesDocument, folderName As String)

' Save picures from document to disk folder (as JPEG files)	



Dim s As New NotesSession

Dim stream As NotesStream

Dim exporter As NotesDXLExporter

Set exporter = s.CreateDXLExporter



Set stream = s.CreateStream

Call exporter.SetInput( d )

Call exporter.SetOutput( stream )

Call exporter.Process



' domParser

Dim domParser As NotesDOMParser

Dim docNode As NotesDOMDocumentNode

Dim docList As NotesDOMNodeList

Dim picNode As NotesDOMTExtNode



Set domParser=s.CreateDOMParser( stream )

domParser.Process



 'Get the document node

Set docNode = domParser.Document



Set docList = docNode.GetElementsByTagName ("jpeg")

If docList.NumberOfEntries = 0 Then  Exit Sub



For i = 1 To docList.NumberOfEntries

	Set picNode = docList.GetItem(i).FirstChild

	

	' Save each picure to file

	Call Decode64SaveFile (picNode.NodeValue,  folderName + "\" + Cstr(d.UniversalID) + "_" + Cstr(i) + ".jpg")

	

Next i

End Sub

Sub Decode64SaveFile (strIn As String, fileName As String)

Const dataSize = 16000



Open fileName For Output As #1



posInStr = 1

dataToDecode$ = Mid$(strIn, posInStr, dataSize)



Do While dataToDecode$ <> ""

	

	dataToDecode$ = RemoveWhitespace(dataToDecode$)

	leftOver$ = leftOver$ & dataToDecode$ 

	dataToDecode$ = Left$(leftOver$, Len(leftOver$) - (Len(leftOver$) Mod 4))

	leftOver$ = Right$(leftOver$, Len(leftOver$) Mod 4)

	

	dataDecoded$ = DecodeBase64(dataToDecode$)

	

	Print #1, dataDecoded$

	Seek #1, Seek(1) - 2

	

	posInStr = posInStr + dataSize

	dataToDecode$ = Mid$(strIn, posInStr, dataSize)

Loop



Close #1

End Sub

Function DecodeBase64 (Byval encText As String) As String

'** This function will decode a Base64 string. It's probably a good

'** idea to check the validity of the string with the IsBase64 function

'** prior to processing it, to avoid strange errors.

'** by Julian Robichaux -- http://www.nsftools.com

'** the characters used to encode in Base64, in order of appearance

Const b64chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"	



On Error Goto endOfFunction



Dim encNum As Long

Dim decText As String

Dim i As Integer



'** remove any line termination characters and whitespace first

encText = RemoveWhitespace(encText)



For i = 1 To Len(encText) Step 4

	'** convert the next 2 of 4 characters to a number we can decode

	encNum = (Instr(b64chars, Mid$(encText, i, 1)) - 1) * (2 ^ 18)

	encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+1, 1)) - 1) * (2 ^ 12))

	

	'** deal with trailing '='

	If (Mid$(encText, i+2, 1) = "=") Then

		decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)

	Elseif (Mid$(encText, i+3, 1) = "=") Then

		encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+2, 1)) - 1) * (2 ^ 6))

		decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)

		decText = decText & Chr(Fix(encNum / (2 ^ 8)) And &HFF)

	Else

		encNum = encNum Or ((Instr(b64chars, Mid$(encText, i+2, 1)) - 1) * (2 ^ 6))

		encNum = encNum Or (Instr(b64chars, Mid$(encText, i+3, 1)) - 1)

		decText = decText & Chr(Fix(encNum / (2 ^ 16)) And &HFF)

		decText = decText & Chr(Fix(encNum / (2 ^ 8)) And &HFF)

		decText = decText & Chr(encNum And &HFF)

	End If

	

Next

endOfFunction:

DecodeBase64 = decText

Exit Function

End Function

Function RemoveWhitespace (Byval text As String) As String

'** remove line terminators, spaces, and tabs from a string

Call ReplaceSubstring(text, Chr(13), "")

Call ReplaceSubstring(text, Chr(10), "")

Call ReplaceSubstring(text, Chr(9), "")

Call ReplaceSubstring(text, " ", "")



RemoveWhitespace = text

End Function

Function ReplaceSubstring (text As String, find As String, replacestr As String)

pos = Instr(text, find)



Do While (pos > 0)

	text = Left$(text, pos - 1) & replacestr & Mid$(text, pos + Len(find))

	pos = Instr(pos + Len(replacestr), text, find)

Loop

End Function