Creating a LinkHotspot in script
Publié: 01 Août 2005 à 12:16[syntax="ls"]Const APIModule = "NNOTES" ' Windows/32 only
Const ERR_ITEM_NOT_FOUND = &H0222
Type BlockID
hPool As Long
Block As Integer
End Type
Type APIItem
Item As BlockID
Filler As Integer
Value As BlockID
Size As Long
End Type
Type NoteLink
File(1) As Long ' replica ID
View(3) As Long ' UNID
Note(3) As Long ' UNID
End Type
Declare Function NSFDbOpen Lib APIModule Alias "NSFDbOpen" _
( Byval PathName As String, DbHandle As Long) As Integer
Declare Function NSFDbClose Lib APIModule Alias "NSFDbClose" _
( Byval DbHandle As Long) As Integer
Declare Function NSFItemInfo Lib APIModule 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 Function NSFItemInfoNext Lib APIModule Alias "NSFItemInfoNext" _
( Byval hNT As Long, Byval pB As Currency, Byval N As String, Byval nN As Integer _
, iB As BlockID, D As Integer, vB As BlockID, nV As Long) As Integer
Declare Function NSFNoteOpen Lib APIModule Alias "NSFNoteOpen" _
( Byval DbHandle As Long, Byval NoteID As Long, Byval F As Integer, hNT As Long) As Integer
Declare Function NSFNoteClose Lib APIModule Alias "NSFNoteClose" _
( Byval hNT As Long) As Integer
Declare Private Function OSMemAlloc Lib APIModule Alias "OSMemAlloc" _
( Byval T As Integer, Byval S As Long, hM As Long) As Integer
Declare Private Function OSMemFree Lib APIModule Alias "OSMemFree" _
( Byval hM As Long) As Integer
Declare Function OSLoadString Lib APIModule Alias "OSLoadString" _
( Byval hMod As Long, Byval Status As Integer, Byval Buffer As String, Byval BufLen As Integer) As Integer
Declare Function OSLockObject Lib APIModule Alias "OSLockObject" _
( Byval H As Long) As Long
Declare Sub OSUnlockObject Lib APIModule Alias "OSUnlockObject" _
( Byval H As Long)
Declare Function OSPathNetConstruct Lib APIModule Alias "OSPathNetConstruct" _
( Byval NullPort As Long, Byval Server As String, Byval FIle As String, Byval PathNet As String) As Integer
Declare Sub NEMDisplayError Lib "NNOTESWS" Alias "NEMDisplayError" _
( Byval E As Long)
Declare Private Sub Peek Lib "MSVCRT" Alias "memcpy" _
( D As Any, Byval P As Long, Byval N As Long)
Declare Private Sub Poke Lib "MSVCRT" Alias "memcpy" _
( Byval P As Long, D As Any, Byval N As Long)
Declare Private Sub PeekString Lib "MSVCRT" Alias "memcpy" _
( Byval S As String, Byval P As Long, Byval N As Long)
Declare Private Sub PokeString Lib "MSVCRT" Alias "memcpy" _
( Byval P As Long, Byval S As String, Byval N As Long)
Declare Private Sub CopyMem Lib "MSVCRT" Alias "memcpy" _
( Byval D As Long, Byval S As Long, Byval N As Long)
Declare Private Sub CopyLS Lib "MSVCRT" Alias "memcpy" _
( D As Any, S As Any, Byval N As Long)
Sub DisplayLinks(doc As NotesDocument, item$)
' construct the full path...
db$ = Space(1024)
With doc.ParentDatabase
OSPathNetConstruct 0, .Server, .FilePath, db$
End With
' open the database...
Dim hDB As Long
NSFDbOpen db$, hDB
If hDB = 0 Then Exit Sub
' open the note...
Dim hNT As Long
NSFNoteOpen hDB, Clng("&H" & doc.NoteID), 0, hNT
If hNT = 0 Then
NSFDbClose hDB
Exit Sub
End If
' read the $Links data into an array...
Dim Link() As NoteLink
Dim iB As BlockID, vB As BlockID
NSFItemInfo hNT, "$LINKS", 6, iB, dt%, vB, nv&
If vB.hPool = 0 Then ' no links
NSFNoteClose hNT
NSFDbClose hDB
Exit Sub
Else
pp& = OSLockObject(vB.hPool) + vB.Block
Peek n%, pp& + 2, 2
Redim Link(n% - 1)
Peek Link(0).File(0), pp& + 4, n% * 40
OSUnlockObject vB.hPool
End If
' read all the Rich Text item info into an array...
Redim A(0) As APIItem
m% = 0 ' counter
tt& = 0 ' total bytes
NSFItemInfo hNT, item$, Len(item$), A(m%).Item, dt%, A(m%).Value, A(m%).Size
While Not A(m%).Size = 0
tt& = tt& + A(m%).Size
m% = m% + 1
Redim Preserve A(m%)
ItemInfoNext hNT, A(m% - 1).Item, item$, Len(item$), A(m%).Item, dt%, A(m%).Value, A(m%).Size
Wend
m% = m% - 1
' copy the actual Rich Text into a memory block...
Dim hM As Long
OSMemAlloc 0, tt&, hM
pm& = OSLockObject(hM)
pp& = pm&
For i% = 0 To m%
Dim aa As APIItem
aa = A(i%)
na& = aa.Size - 2
pv& = OSLockObject(aa.Value.hPool) + aa.Value.Block + 2
CopyMem pp&, pv&, na&
OSUnlockObject aa.Value.hPool
pp& = pp& + na&
Next
' scan the Rich Text for composite data records...
Do
GetCD pm&, tt&, toff&, tlen&, sig%
If sig% = 145 Then ' CDLINK2
Peek clength%, pm& + toff& + 2, 2
Peek cindex%, pm& + toff& + 4, 2
s% = clength% - 6
t$ = Space(s%)
PeekString t$, pm& + toff& + 6, s%
p% = Instr(t$, Chr$(0))
comment$ = Left$(t$, p% - 1)
t$ = Mid$(t$, p% + 1)
p% = Instr(t$, Chr$(0))
hint$ = Left$(t$, p% - 1)
t$ = Mid$(t$, p% + 1)
p% = Instr(t$, Chr$(0))
anchor$ = Left$(t$, p% - 1)
dbID$ = ReplicaID(Link(cindex%))
vwID$ = ViewUNID(Link(cindex%))
docID$ = DocumentUNID(Link(cindex%))
Messagebox "CDLINK2 at &H" & Hex$(toff&) & " length: &H" & Hex$(clength%) & " index: " & Cstr(cindex%) _
& Chr$(10) & comment$ _
& Chr$(10) & "Replica: " & dbID$ _
& Chr$(10) & "View: " & vwID$ _
& Chr$(10) & "Note: " & docID$ _
& Chr$(10) & "Anchor: " & anchor$ _
& Chr$(10) & "Server hint: " & hint$
End If
Loop Until sig% = 0
' clean up...
OSUnlockObject hM
OSMemFree hM
NSFNoteClose hNT
NSFDbClose hDB
End Sub
Function DocumentUNID(L As NoteLink) As String
DocumentUNID = "OF" & LongHex(L.Note(1)) & ":" & LongHex(L.Note(0)) _
& "-ON" & LongHex(L.Note(3)) & ":" & LongHex(L.Note(2))
End Function
Sub GetCD(pointer As Long, length As Long, cdoffset As Long, cdlength As Long, cdsig As Integer)
Static R As Long
Do
Peek i%, pointer + R, 2
cdsig% = i% And &HFF
cdlength = (i% And &HFF00) / 256
If cdlength = -1 Then
cdlength = 0
Peek cdlength, pointer + R + 2, 2
Elseif cdlength = 0 Then
Peek cdlength, pointer + R + 2, 4
End If
cdoffset = R
If cdsig% = 0 Then R = R + 1 Else R = R + cdlength
Loop Until R >= length Or Not cdsig% = 0
If R >= length Then
cdoffset = 0
cdlength = 0
cdsig% = 0
R = 0
End If
End Sub
Private Sub ItemInfoNext(hNT&, pB As BlockID, N$, nN%, iB As BlockID, D%, vB As BlockID, nV&)
Dim pBc As Currency
Dim Z(1) As Long
Z(1) = 0
CopyLS pBc, Z(0), 8
CopyLS pBc, pB.hPool, 6
st% = NSFItemInfoNext(hNT&, pBc, N$, nN%, iB, D%, vB, nV&)
If Not st% = 0 And Not st% = ERR_ITEM_NOT_FOUND Then Error 1000, "API error &H" & Hex$(st%)
End Sub
Function LongHex(N As Long) As String
LongHex = Right$(String$(7, "0") & Hex$(N),
End Function
Function ReplicaID(L As NoteLink) As String
ReplicaID = LongHex(L.File(1)) & ":" & LongHex(L.File(0))
End Function
Function ViewUNID(L As NoteLink) As String
ViewUNID = "OF" & LongHex(L.View(1)) & ":" & LongHex(L.View(0)) _
& "-ON" & LongHex(L.View(3)) & ":" & LongHex(L.View(2))
End Function[/syntax]
Const ERR_ITEM_NOT_FOUND = &H0222
Type BlockID
hPool As Long
Block As Integer
End Type
Type APIItem
Item As BlockID
Filler As Integer
Value As BlockID
Size As Long
End Type
Type NoteLink
File(1) As Long ' replica ID
View(3) As Long ' UNID
Note(3) As Long ' UNID
End Type
Declare Function NSFDbOpen Lib APIModule Alias "NSFDbOpen" _
( Byval PathName As String, DbHandle As Long) As Integer
Declare Function NSFDbClose Lib APIModule Alias "NSFDbClose" _
( Byval DbHandle As Long) As Integer
Declare Function NSFItemInfo Lib APIModule 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 Function NSFItemInfoNext Lib APIModule Alias "NSFItemInfoNext" _
( Byval hNT As Long, Byval pB As Currency, Byval N As String, Byval nN As Integer _
, iB As BlockID, D As Integer, vB As BlockID, nV As Long) As Integer
Declare Function NSFNoteOpen Lib APIModule Alias "NSFNoteOpen" _
( Byval DbHandle As Long, Byval NoteID As Long, Byval F As Integer, hNT As Long) As Integer
Declare Function NSFNoteClose Lib APIModule Alias "NSFNoteClose" _
( Byval hNT As Long) As Integer
Declare Private Function OSMemAlloc Lib APIModule Alias "OSMemAlloc" _
( Byval T As Integer, Byval S As Long, hM As Long) As Integer
Declare Private Function OSMemFree Lib APIModule Alias "OSMemFree" _
( Byval hM As Long) As Integer
Declare Function OSLoadString Lib APIModule Alias "OSLoadString" _
( Byval hMod As Long, Byval Status As Integer, Byval Buffer As String, Byval BufLen As Integer) As Integer
Declare Function OSLockObject Lib APIModule Alias "OSLockObject" _
( Byval H As Long) As Long
Declare Sub OSUnlockObject Lib APIModule Alias "OSUnlockObject" _
( Byval H As Long)
Declare Function OSPathNetConstruct Lib APIModule Alias "OSPathNetConstruct" _
( Byval NullPort As Long, Byval Server As String, Byval FIle As String, Byval PathNet As String) As Integer
Declare Sub NEMDisplayError Lib "NNOTESWS" Alias "NEMDisplayError" _
( Byval E As Long)
Declare Private Sub Peek Lib "MSVCRT" Alias "memcpy" _
( D As Any, Byval P As Long, Byval N As Long)
Declare Private Sub Poke Lib "MSVCRT" Alias "memcpy" _
( Byval P As Long, D As Any, Byval N As Long)
Declare Private Sub PeekString Lib "MSVCRT" Alias "memcpy" _
( Byval S As String, Byval P As Long, Byval N As Long)
Declare Private Sub PokeString Lib "MSVCRT" Alias "memcpy" _
( Byval P As Long, Byval S As String, Byval N As Long)
Declare Private Sub CopyMem Lib "MSVCRT" Alias "memcpy" _
( Byval D As Long, Byval S As Long, Byval N As Long)
Declare Private Sub CopyLS Lib "MSVCRT" Alias "memcpy" _
( D As Any, S As Any, Byval N As Long)
Sub DisplayLinks(doc As NotesDocument, item$)
' construct the full path...
db$ = Space(1024)
With doc.ParentDatabase
OSPathNetConstruct 0, .Server, .FilePath, db$
End With
' open the database...
Dim hDB As Long
NSFDbOpen db$, hDB
If hDB = 0 Then Exit Sub
' open the note...
Dim hNT As Long
NSFNoteOpen hDB, Clng("&H" & doc.NoteID), 0, hNT
If hNT = 0 Then
NSFDbClose hDB
Exit Sub
End If
' read the $Links data into an array...
Dim Link() As NoteLink
Dim iB As BlockID, vB As BlockID
NSFItemInfo hNT, "$LINKS", 6, iB, dt%, vB, nv&
If vB.hPool = 0 Then ' no links
NSFNoteClose hNT
NSFDbClose hDB
Exit Sub
Else
pp& = OSLockObject(vB.hPool) + vB.Block
Peek n%, pp& + 2, 2
Redim Link(n% - 1)
Peek Link(0).File(0), pp& + 4, n% * 40
OSUnlockObject vB.hPool
End If
' read all the Rich Text item info into an array...
Redim A(0) As APIItem
m% = 0 ' counter
tt& = 0 ' total bytes
NSFItemInfo hNT, item$, Len(item$), A(m%).Item, dt%, A(m%).Value, A(m%).Size
While Not A(m%).Size = 0
tt& = tt& + A(m%).Size
m% = m% + 1
Redim Preserve A(m%)
ItemInfoNext hNT, A(m% - 1).Item, item$, Len(item$), A(m%).Item, dt%, A(m%).Value, A(m%).Size
Wend
m% = m% - 1
' copy the actual Rich Text into a memory block...
Dim hM As Long
OSMemAlloc 0, tt&, hM
pm& = OSLockObject(hM)
pp& = pm&
For i% = 0 To m%
Dim aa As APIItem
aa = A(i%)
na& = aa.Size - 2
pv& = OSLockObject(aa.Value.hPool) + aa.Value.Block + 2
CopyMem pp&, pv&, na&
OSUnlockObject aa.Value.hPool
pp& = pp& + na&
Next
' scan the Rich Text for composite data records...
Do
GetCD pm&, tt&, toff&, tlen&, sig%
If sig% = 145 Then ' CDLINK2
Peek clength%, pm& + toff& + 2, 2
Peek cindex%, pm& + toff& + 4, 2
s% = clength% - 6
t$ = Space(s%)
PeekString t$, pm& + toff& + 6, s%
p% = Instr(t$, Chr$(0))
comment$ = Left$(t$, p% - 1)
t$ = Mid$(t$, p% + 1)
p% = Instr(t$, Chr$(0))
hint$ = Left$(t$, p% - 1)
t$ = Mid$(t$, p% + 1)
p% = Instr(t$, Chr$(0))
anchor$ = Left$(t$, p% - 1)
dbID$ = ReplicaID(Link(cindex%))
vwID$ = ViewUNID(Link(cindex%))
docID$ = DocumentUNID(Link(cindex%))
Messagebox "CDLINK2 at &H" & Hex$(toff&) & " length: &H" & Hex$(clength%) & " index: " & Cstr(cindex%) _
& Chr$(10) & comment$ _
& Chr$(10) & "Replica: " & dbID$ _
& Chr$(10) & "View: " & vwID$ _
& Chr$(10) & "Note: " & docID$ _
& Chr$(10) & "Anchor: " & anchor$ _
& Chr$(10) & "Server hint: " & hint$
End If
Loop Until sig% = 0
' clean up...
OSUnlockObject hM
OSMemFree hM
NSFNoteClose hNT
NSFDbClose hDB
End Sub
Function DocumentUNID(L As NoteLink) As String
DocumentUNID = "OF" & LongHex(L.Note(1)) & ":" & LongHex(L.Note(0)) _
& "-ON" & LongHex(L.Note(3)) & ":" & LongHex(L.Note(2))
End Function
Sub GetCD(pointer As Long, length As Long, cdoffset As Long, cdlength As Long, cdsig As Integer)
Static R As Long
Do
Peek i%, pointer + R, 2
cdsig% = i% And &HFF
cdlength = (i% And &HFF00) / 256
If cdlength = -1 Then
cdlength = 0
Peek cdlength, pointer + R + 2, 2
Elseif cdlength = 0 Then
Peek cdlength, pointer + R + 2, 4
End If
cdoffset = R
If cdsig% = 0 Then R = R + 1 Else R = R + cdlength
Loop Until R >= length Or Not cdsig% = 0
If R >= length Then
cdoffset = 0
cdlength = 0
cdsig% = 0
R = 0
End If
End Sub
Private Sub ItemInfoNext(hNT&, pB As BlockID, N$, nN%, iB As BlockID, D%, vB As BlockID, nV&)
Dim pBc As Currency
Dim Z(1) As Long
Z(1) = 0
CopyLS pBc, Z(0), 8
CopyLS pBc, pB.hPool, 6
st% = NSFItemInfoNext(hNT&, pBc, N$, nN%, iB, D%, vB, nV&)
If Not st% = 0 And Not st% = ERR_ITEM_NOT_FOUND Then Error 1000, "API error &H" & Hex$(st%)
End Sub
Function LongHex(N As Long) As String
LongHex = Right$(String$(7, "0") & Hex$(N),
End Function
Function ReplicaID(L As NoteLink) As String
ReplicaID = LongHex(L.File(1)) & ":" & LongHex(L.File(0))
End Function
Function ViewUNID(L As NoteLink) As String
ViewUNID = "OF" & LongHex(L.View(1)) & ":" & LongHex(L.View(0)) _
& "-ON" & LongHex(L.View(3)) & ":" & LongHex(L.View(2))
End Function[/syntax]