Const ODS_DWORD = 0
Type BlockID
pool As Long
block As Long
End Type
Type WSIG
signature As Integer
length As Integer
End Type
Type CDACTIONLOTUSSCRIPT
header As WSIG
dwFlags As Long
dwScriptLen As Long
End Type
Type CDACTIONFORMULA
header As WSIG
dwFlags As Long
dwFormulaLen As Long
End Type
Declare Sub apiOSMemFree Lib "nnotes.dll" Alias "OSMemFree" (Byval handle As Long)
Declare Function apiNSFFormulaDecompile Lib "nnotes.dll" Alias "NSFFormulaDecompile" (Byval P As Long, Byval S As Integer, hT As Long, N As Long) As Integer
Declare Function apiNSFItemInfo Lib "nnotes.dll" Alias "NSFItemInfo" (Byval lng_notehandle As Long, Byval str_itemname As Lmbcs String, Byval int_namelen As Integer, bi_item As BlockID, int_valuedatatype As Integer, bi_value As BlockID, lng_valuelen As Long) As Integer
Declare Function apiOSLockObject Lib "nnotes.dll" Alias "OSLockObject" (Byval handle As Long) As Long
Declare Sub apiOSUnlockObject Lib "nnotes.dll" Alias "OSUnlockObject" (Byval handle As Long)
Declare Private Sub apiPeek Lib "MSVCRT" Alias "memcpy" (D As Any, Byval P As Long, Byval N As Long)
Declare Sub apiODSReadMemory Lib "nnotes.dll" Alias "ODSReadMemory" (pSource As Long, Byval typeODS As Integer, pDest As Any, Byval Iterations As Integer )
Declare Sub apiPeekString Lib "MSVCRT" Alias "memcpy" (Byval D As String, Byval P As Long, Byval N As Long)
Sub Click(Source As Button)
Dim ag As NotesAgent
Dim bi_item As BlockID
Dim bi_value As BlockID
Dim db As NotesDatabase
Dim db_check As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Dim doc_ag As NotesDocument
Dim int_apiresult As Integer
Dim int_valuedatatype As Integer
Dim lng_dbhandle As Long
Dim lng_notehandle As Long
Dim lng_valuelen As Long
Dim lng_buffer As Long
Dim rec As CDACTIONLOTUSSCRIPT
Dim s As NotesSession
Dim str_agent As String
Dim str_item As String
Dim str_unid As String
Dim uidoc As NotesUIDocument
Dim uiws As NotesUIWorkspace
' ### initialize ###
Set uiws = New NotesUIWorkspace
Set uidoc = uiws.CurrentDocument
Set doc = uidoc.Document
Set s = New NotesSession
Set db = s.CurrentDatabase
' ### validation ###
If doc.LogServer(0) = "" Or doc.LogDatabase(0) = "" Or doc.LogObject(0) = "" Then
Messagebox "Missing informations", MB_OK + MB_ICONEXCLAMATION, db.Title
Exit Sub
End If
' ### open source database ###
Set db_check = s.GetDatabase(doc.LogServer(0), doc.LogDatabase(0), False)
If db_check Is Nothing Then
Messagebox "File " & doc.LogDatabase(0) & " does not exist", MB_OK + MB_ICONEXCLAMATION, db.Title
Exit Sub
End If
' ### get agent name ###
str_agent = doc.LogObject(0)
If Instr(str_agent, "|") > 0 Then str_agent = Strleft(str_agent, "|")
' ### get agent ###
Set ag = db_check.GetAgent(str_agent)
If ag Is Nothing Then
Messagebox "Could not find agent " & str_agent & " in database " & doc.LogDatabase(0), MB_OK + MB_ICONEXCLAMATION, db.Title
Exit Sub
End If
' ### get universal id of the agent ###
str_unid = Strleft(Strright(ag.NotesURL, ".nsf/"), "?OpenAgent")
If str_unid = "" Then
Messagebox "Could get UniversalID of the agent " & str_agent & " in database " & doc.LogDatabase(0), MB_OK + MB_ICONEXCLAMATION, db.Title
Exit Sub
End If
' ### get design document ###
Set doc_ag = db_check.GetDocumentByUNID(str_unid)
If doc_ag Is Nothing Then
Messagebox "Could not get design document of the agent " & str_agent & " in database " & doc.LogDatabase(0), MB_OK + MB_ICONEXCLAMATION, db.Title
Exit Sub
End If
If Instr(doc_ag.~$Flags(0), "L") = 0 Then
Messagebox str_agent & " is not an lotus script agent!", MB_OK + MB_ICONEXCLAMATION, db.Title
Exit Sub
End If
' ### get item informations ###
str_item = "$AssistAction"
int_apiresult = apiNSFItemInfo(doc_ag.handle, str_item, Len(str_item), bi_item, int_valuedatatype, bi_value, lng_valuelen)
If Not(int_apiresult = 0) Then
Error int_apiresult, BEGetAPIError(int_apiresult)
End If
' ### read informations ###
lng_buffer = apiOSLockObject(bi_value.Pool) + bi_value.Block ' LockBlock(vB)
Call apiODSReadMemory (lng_buffer, ODS_DWORD, rec.header.signature, 1)
Call apiODSReadMemory (lng_buffer, ODS_DWORD, unknown, 1)
Call apiODSReadMemory (lng_buffer, ODS_DWORD, rec.dwFlags, 1)
Call apiODSReadMemory (lng_buffer, ODS_DWORD, rec.dwScriptLen, 1)
Dim word As Long
Dim code As String
Dim i As Integer
code = ""
For i = 7 To rec.dwScriptLen -5
apiPeek word&, lng_buffer + i, 1
If word& > 0 Then code = code & Chr$(word&)
Next
Call apiOSUnlockObject(bi_value.Pool)
' ### open source code ###
Dim doc_dlg As NotesDocument
Dim item As NotesItem
Dim rti As NotesRichTextItem
Set doc_dlg = db.CreateDocument
doc_dlg.Form = "AgentSourceCode"
doc_dlg.Agent = ag.Name
Set item = New NotesItem(doc_dlg, "Server", db_check.Server, NAMES)
Set rti = doc_dlg.CreateRichTextItem("Link")
Call rti.AppendDocLink(db_check, db_check.Title)
Call rti.Update
doc_dlg.Code = code
Call uiws.EditDocument(False, doc_dlg, True)
End Sub