Option Declare Option Compare NoCase '# Special Thanks to Rob Whiteley for this Lotus Developer Domain forum post: '# http://www-10.lotus.com/ldd/46dom.nsf/0/564e5f7e34eb52e880256cec0064759f?OpenDocument Const SIG_CD_IMAGESEGMENT = 124% Const SIG_CD_IMAGEHEADER = 125% Const SIG_CD_GRAPHIC = 153% Const SIG_CD_BEGIN = 221% + &H0600% ' includes length Const SIG_CD_END = 222% + &H0600% ' includes length Const CDIMAGETYPE_GIF= 1% Const CDIMAGETYPE_JPEG = 2% Const CDIMAGETYPE_BMP = 3% ' Notes 6 Const MAX_SEG = &H2800% Const MAX_ITEM = &HA000& Const wAPIModule = "NNOTES" ' Windows/32 Const wUIModule = "NNOTESWS" 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 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) Type SegmentData Data(MAX_SEG / 4 - 1) As Long End Type 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 Delete 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 Call Poke (V, pointer, n&) pointer = pointer + n& End Sub Public Sub Read(f As Integer, n As Integer) On Error 62 Resume Next ' allow input past EoF 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 End Class Sub Initialize Dim s As New NotesSession Dim db As NotesDatabase Dim view As NotesView Dim doc As NotesDocument Dim tDoc As NotesDocument Dim EmployeeID$, ImageFilePath$ Const BasePath$ = "F:\PHOTOS\" '# path containing the JPG pictures Const PictureItem$ = "UserPhoto" '# name of RichText field in the person document '# loop all person documents in the Domino Directory Set db = New NotesDatabase ("","names.nsf") Set view = db.getView ("($VIMPeople)") If Not view Is Nothing Then Set doc = view.Getfirstdocument() While Not doc Is nothing Set tDoc = view.Getnextdocument(doc) EmployeeID$ = Doc.GetItemValue ("EmployeeID")(0) If EmployeeID$ = "" Then '# skip Else '# go ahead and import ImageFilePath$ = BasePath$ & EmployeeID$ & ".jpg" Call ImportPictureToDocument (doc, PictureItem$, ImageFilePath$, True) End If Set doc = tDoc wend Else '# unable to find view '$VIMPeople' in Domino Directory Error 1000, "unable To find view '$VIMPeople' in Domino Directory" End If End Sub Sub CreateImageItem(doc As NotesDocument, itemname As String, imagefile As String) Dim hNT As Long Dim filenum%, filetype%, v%, imgSizeX%, imgSizeY%, n%, t%, dsize%, ssize% Dim i&, filesize&, segments&, p& hNT = doc.Handle If hNT = 0 Then Error 1000, "No document handle" Dim buf As New ItemBuffer(hNT, itemname) filenum% = FreeFile() Open imagefile For Binary Access Read As #filenum% filesize& = LOF(filenum%) If filesize& = 0 Then Error 1000, "Can not open file " & imagefile segments& = -Int(-filesize& / MAX_SEG) ' round up '# Get data type from binary file Get #filenum%, , v% Select Case v% Case &H4947 : filetype% = CDIMAGETYPE_GIF Get #filenum%, 7, imgSizeX% Get #filenum%, 9, imgSizeY% Case &HD8FF : filetype% = CDIMAGETYPE_JPEG p& = 3 n% = 0 While Not (t% = &HC0FF Or t% = &HC2FF) ' SOFn p& = p& + n% Get #filenum%, p&, t% ' marker type p& = p& + 2 Get #filenum%, p&, n% ' length Invert n% Wend If t% = &HC0FF Or t% = &HC2FF Then Get #filenum%, p& + 3, imgSizeY% Invert imgSizeY% Get #filenum%, p& + 5, imgSizeX% Invert imgSizeX% Else Error 1000, "Can't understand JPEG format" End If Case &H4D42 : filetype% = CDIMAGETYPE_BMP ' Notes 6 Get #filenum%, 19, imgSizeX% Get #filenum%, 23, imgSizeY% Case Else : Error 1000, "Unrecognized image format" End Select Seek #filenum%, 1 With buf .Record SIG_CD_BEGIN .Put 1% ' version .Put SIG_CD_GRAPHIC .Record SIG_CD_GRAPHIC .Put 28& ' length .Put 0& ' dest .Put 0& ' crop .Put 0& ' off1 .Put 0& ' off2 .Put 0% ' resized .Put 1% ' version .Put 0% ' junk .Record SIG_CD_IMAGEHEADER .Put 28& ' length .Put filetype% .Put imgSizeX% .Put imgSizeY% .Put filesize& .Put segments& .Put 0& ' flags .Put 0& ' junk For i& = 1 To segments& If i& = segments& Then dsize% = filesize& Mod MAX_SEG Else dsize% = MAX_SEG ssize% = dsize% + (dsize% And 1) ' round up .Record SIG_CD_IMAGESEGMENT .Put CLng(ssize% + 10) ' length .Put dsize% .Put ssize% .Read filenum%, ssize% Next .Record SIG_CD_END .Put 1% ' version .Put SIG_CD_GRAPHIC .Save End With Close #filenum% End Sub Sub Invert(n As Integer) Dim h$ h$ = Right$("000" & Hex$(n), 4) n = CInt("&H" & Right$(h$, 2) & Left$(h$, 2)) End Sub Function ImportPictureToDocument (doc As NotesDocument, PictureItem As String, ImageFilePath As String, Recreate As Boolean) '# usage: '# doc : NotesDocument to which the new field shall be added '# PictureItem : Name of NotesRichtTextItem that will be created '# ImageFilePath : path and filename of (supported) image file '# Recreate : when set to TRUE it will delete/overwrite NotesItems with the same name If Not doc Is Nothing Then '# remove any item with this name If Recreate Then Call doc.Removeitem(PictureItem) '# check if file exists If Dir$(ImageFilePath) = "" Then '# file does not exist Exit function End If '# insert new RichTextItem + image Call CreateImageItem (doc, PictureItem$, ImageFilePath) '# save Call Doc.Save (True, False) End If End Function