%REM
	Agent DBIconToGIF
	Description:
	データベースアイコンをGIFファイルへ出力する
%END REM
Option Public
Option Declare

Const SIG_CD_BITMAPHEADER = 149
Const SIG_CD_BITMAPSEGMENT = 150
Const SIG_CD_COLORTABLE = 151
Const SIG_CD_GRAPHIC = 153%
Const SIG_CD_TRANSPARENTTABLE = 197

Const MAX_SEG = &H2800%
Const MAX_ITEM = &HA000&

Const wAPIModule = "NNOTES"
Const wUIModule = "NNOTESWS"

Public Type BlockID
     hPool As Long
     Block As Integer
End Type

Type SegmentData
     Data(MAX_SEG / 4 - 1) As Long
End Type

Declare Private Function OSMemoryAllocate Lib wAPIModule Alias "OSMemoryAllocate" _
(  ByVal T As Integer, ByVal S As Long, hM As Long) As Integer
Declare Private Function OSMemoryLock Lib wAPIModule Alias "OSMemoryLock" _
(  ByVal hM As Long) As Long
Declare Private Function OSMemoryUnlock Lib wAPIModule Alias "OSMemoryUnlock" _
(  ByVal hM As Long) As Long
Declare Private Function OSMemoryFree Lib wAPIModule Alias "OSMemoryFree" _
(  ByVal hM As Long) As Integer
Declare Private Sub Poke Lib wAPIModule Alias "Cmovmem" _
(  S As Any, ByVal P As Long, ByVal N As Long)
Declare Private Function NSFItemAppend Lib wAPIModule Alias "NSFItemAppend" _
(  ByVal hNT As Long, ByVal F As Integer, ByVal N As String, ByVal nN As Integer _
, ByVal T As Integer, ByVal V As Long, ByVal nV As Long) As Integer
Declare Sub NEMDisplayError Lib wUIModule Alias "NEMDisplayError" _
(  ByVal E As Long)
Declare Private Function NSFItemInfo Lib wAPIModule Alias "NSFItemInfo" _
(  ByVal hNT As Long, ByVal N As String, ByVal nN As Integer _
,  iB As BlockID, D As Integer, vB As BlockID, nV As Long) As Integer
Declare Private Function OSLockObject Lib wAPIModule Alias "OSLockObject" _
(  ByVal hM As Long) As Long
Declare Private Sub Peek Lib wAPIModule Alias "Cmovmem" _
(  ByVal P As Long, D As Any, ByVal N As Long)
Declare Public Sub OSUnlockObject Lib wAPIModule Alias "OSUnlockObject" _
(  ByVal hM As Long)

Public Class ItemBuffer
	Private address As Long     
	Private hM As Long
	Private hNT As Long
	Private itemname As String
	Private seg As SegmentData 
	Private pointer As Long

	Public Sub New(hNT As Long, itemname As String)
		Me.hNT = hNT
		Me.itemname = itemname
		OSMemoryAllocate 0, MAX_ITEM + MAX_SEG + 256, hM
		address = OSMemoryLock(hM)
		pointer = address
	End Sub

	Public Sub Del
		If hM = 0 Then Exit Sub
		OSMemoryUnlock hM
		OSMemoryFree hM
		hM = 0
	End Sub
	
	Public Sub Put(V As Variant)
		Dim n&
		Select Case TypeName(V)
		Case "INTEGER" : n& = 2
		Case "LONG" : n& = 4
		Case Else : Exit Sub
		End Select
		Poke V, pointer, n&
		pointer = pointer + n&
	End Sub
	
	Public Sub Read(f As Integer, n As Integer)
		On Error 62 Resume Next
		Get #f%, , seg
		On Error GoTo 0
		Poke seg, pointer, n
		pointer = pointer + n
	End Sub
	
	Public Sub Record(V As Variant)
		If pointer - address > MAX_ITEM Then Save
		Me.Put V
	End Sub
	
	Public Sub Save
		Dim s%
		s% = NSFItemAppend( hNT, 0, itemname, Len(itemname), 1, address, pointer - address)
		If Not s% = 0 Then NEMDisplayError s%
		pointer = address
	End Sub

	Public Sub PutByte(v%)
		Poke v%, pointer, 1
		pointer = pointer + 1
	End Sub

	Public Sub PutRGB(v&)
		Poke v&, pointer, 3
		pointer = pointer + 3
	End Sub
End Class
Sub Initialize
	Dim ss As New NotesSession
	Dim tdb As NotesDatabase '取得したいアイコンがあるアプリケーション
	Dim cdb As NotesDatabase 'エージェントがあるアプリケーション
	Dim filepath$ '出力するgifファイルのパス
	
	Set tdb = ss.Currentdatabase
	Set cdb = ss.Currentdatabase
	filepath = "C:\Temp\image.gif"
	
	main tdb, cdb, filepath

End Sub
%REM
	Sub notesbitmapToFile
	Description: インラインイメージの文字列をGIFファイルへ変換/出力する
%END REM
Sub notesbitmapToFile( notesbitmap As String, filepath As String )
	Dim ss As New NotesSession
	Dim stream As NotesStream
	Dim doc As NotesDocument
	Dim mimeEntity As NotesMIMEEntity
	
	Set stream = ss.CreateStream
	stream.Writetext notesbitmap, 5
	Set doc = New NotesDocument( ss.Currentdatabase )
	Set mimeEntity = doc.CreateMIMEEntity
	mimeEntity.SetContentFromBytes stream, "image/gif", ENC_BASE64

	stream.Truncate
	stream.Open filepath, "binary"
	stream.Truncate
	mimeEntity.GetContentAsBytes stream
	stream.Close
End Sub
%REM
	Sub main
	Description:DBアイコンをファイルへ出力
%END REM
Sub main( tdb As NotesDatabase, curdb As NotesDatabase, filepath$ )
	Dim doc As NotesDocument
	Set doc = New NotesDocument( curdb )
	Dim icon As NotesDocument
	Set icon = tdb.GetDocumentByID( "FFFF0010" ) 'icon note

	Dim iB As BlockID, vB As BlockID
	Dim dt%, nv&
	NSFItemInfo icon.Handle, "IconBitmap", 10, iB, dt%, vB, nv&
	If vB.hPool = 0 Then Exit Sub
	If Not nv& = 648 Then Exit Sub

	Dim b As New NotesRichTextItem( doc, "Body" )
	doc.Save True, False

	Dim cdb As New ItemBuffer( doc.Handle, "Body" )
	With cdb
		.Record SIG_CD_GRAPHIC
		.Put 28&
		.Put 0&
		.Put 0&
		.Put 0&
		.Put 0&
		.Put 0%
		.Put 2%
		.Put 0%
		
		.Record SIG_CD_BITMAPHEADER
		.Put 38&
		.Put 0&
		.Put 0&
		.Put 0%
		.Put 0%
		.Put 0&
		.Put 32%
		.Put 32%
		.Put 8%
		.Put 1%
		.Put 8%
		.Put 1%
		.Put 17%
		.Put 0%
		
		.Record SIG_CD_TRANSPARENTTABLE
		.Put 13&
		.Put 0%
		.Put 1%
		.PutRGB &HEEEEEE&
		.PutByte 0
		
		.Record SIG_CD_BITMAPSEGMENT
		.Put 1074&
		.Put 0&
		.Put 0&
		.Put 32%
		.Put 1056%
		
		Dim ia&, br&, tr&, row%, bp&, tp&, grp%, t%, v%, col%
		ia& = OSLockObject(vB.hPool) + (vB.Block And &HFFFF&)
		ia& = ia& + 2 + 6
		br& = ia& + 640
		tr& = ia& + 128
		
		For row% = 0 To 31
			.PutByte 32
			br& = br& - 16
			bp& = br&
			tr& = tr& - 4
			tp& = tr&
			For grp% = 0 To 3
				Peek tp&, t%, 1
				tp& = tp& + 1
				For col% = 0 To 3
					Peek bp&, v%, 1
					bp& = bp& + 1
					v% = (v% And &HF0) \ &H10 + (v% And &H0F) * &H0100
					If t% And &H40 Then v% = v% And &H00FF Or &H1000
					If t% And &H80 Then v% = v% And &HFF00 Or &H0010
					t% = (t% And &H3F) * 4
					.Put v%
				Next
			Next
		Next          
		
		OSUnlockObject vB.hPool
		
		.Record SIG_CD_COLORTABLE
		.Put 57&
		.PutRGB &H000000&
		.PutRGB &HFFFFFF&
		.PutRGB &H0000FF&
		.PutRGB &H00FF00&
		.PutRGB &HFF0000&
		.PutRGB &HFF00FF&
		.PutRGB &H00FFFF&
		.PutRGB &HFFFF00&
		.PutRGB &H0000800&
		.PutRGB &H008000&
		.PutRGB &H800000&
		.PutRGB &H800080&
		.PutRGB &H008080&
		.PutRGB &H808000&
		.PutRGB &HC0C0C0&
		.PutRGB &H808080&
		.PutRGB &HEEEEEE&
		.PutByte 0
		
		.Save
		.Del
	End With

	doc.Save True, False
	
	Dim bitmap$
	If getNotesbitmap( doc, bitmap ) Then
		notesbitmapToFile bitmap, filepath
	End If
	
	doc.Remove False
End Sub
%REM
	Function getNotesbitmap
	Description: DXL化した文書からインラインイメージを抽出
%END REM
Function getNotesbitmap( doc As NotesDocument, notesbitmap As String ) As Boolean
	Dim ss As New NotesSession
	Dim exporter As NotesDXLExporter
	Dim out$, gifdatastart%, gifdatafinish%
	Const FINDTAG1 = "<gif originalformat='notesbitmap'>"
	Const FINDTAG2 = "</gif>"
	getNotesbitmap = False

	Set exporter = ss.CreateDXLExporter
	exporter.ConvertNotesBitmapsToGIF = True
	out = exporter.Export( doc )

	gifdatastart = InStr( out, FINDTAG1 )
	gifdatafinish = InStr( gifdatastart, out, FINDTAG2 )
	notesbitmap = Mid( out, gifdatastart + Len( FINDTAG1 ) + 1, gifdatafinish - gifdatastart - Len( FINDTAG1 ) - 1 )

	getNotesbitmap = True
End Function