Title:

LotusScript Gold Collection


Description:

This is not a complete application, but a toolkit of reusable LotusScript libraries that can be included in your applications. There may also be any required supporting design elements (subform used in dialog, etc), and sample code to show how the functions in the script libraries are invoked.



Contributors:

Andre Guirard


Catalog Entry URL:
http://www.openntf.org/catalogs/a2cat.nsf/topicThread.xsp?action=openDocument&documentId=B845D36ED98E6AAB8525771100270318

Download URL:
http://www.openntf.org/Projects/pmt.nsf/downloadcounter?openagent&project=LotusScript%20Gold%20Collection&release=1.2&unid=B084946C5B3456318625770C005D61EB&attachment=LSGold-1-2.zip

Date:
04/26/2010

Main Doc UNID:
D0CA44F83FF8307586257616006C6D64

Project Code: '++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent Image size test
Created Mar 31, 2010 by Andre Guirard/Cambridge/IBM
Description: Unit test for CalculateImageSize function.
%END REM
Option Public
Option Declare
Use "EmbeddedImage"
Use "UIHelper"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim wksp As New NotesUIWorkspace, session As New NotesSession
Dim ui As New UIHelper(session.Currentdatabase)
Dim fname, res$
Const NL = {
}

fname = ui.OpenFilePrompt(True, "Test Image Dimensions", "Images (jpg, gif, png)|*.png;*.jpg;*.gif;*.jpeg", "")
ForAll thing In fname
Dim stream As NotesStream, h As Long, w As Long, tnam$, success As Boolean

Set stream = session.createstream
stream.Open thing
success = CalculateImageSize(Stream, h, w, tnam)
res = res & NL & StrToken(thing, "\", -1)
If success Then
res = res & " " & tnam & "(" & h & " x " & w & ")"
Else
res = res & " FAILED"
End If
End ForAll
MsgBox Mid$(res, 2)
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent object list unit test
Created Mar 31, 2010 by Andre Guirard/Cambridge/IBM
Description: Tests all the functions of the ObjectList class.
%END REM
Option Public
Option Declare
Use "ObjectList"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize
Declare Function getIDs(ol As ObjectList) As string
Declare Sub CurrentIs(ol As ObjectList, ByVal id$, ByVal pos As Long, ByVal testID$)
Declare Function newDoc(ByVal ID$) As NotesDocument
Declare Function getIDsFL(ol As ObjectList) As String
Declare Sub ListIs(ol As objectList, ByVal expected$, ByVal curID$, ByVal pos%, ByVal testID$)
Declare Function getIDsBL(ol As ObjectList) As String

'++LotusScript Development Environment:2:5:(Declarations):0:10
Dim db As NotesDatabase

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
On Error GoTo oops
Dim ol As New ObjectList
Dim session As New NotesSession
Set db = session.Currentdatabase
Dim docA As NotesDocument, docB As NotesDocument, docC As NotesDocument
Dim expectErr As Boolean
If ol.count Then Error 99, "[4.1]"
CurrentIs ol, "", 0, "[12.1] [5.1]"
If Not (ol.First Is Nothing) Then Error 99, "[7.1]"
If Not (ol.Next Is Nothing) Then Error 99, "[10.1]"
If Not (ol.Last Is Nothing) Then Error 99, "[9.1]"

Set docA = newDoc("A")
Set docB = newDoc("B")
Set docC = newDoc("C")

ol.Append docA
ListIs ol, "A", "A", 0, "[3.1]"
ol.AddAt 0, docB ' [2.1]
ListIs ol, "B,A", "B", 0, "[2.6] [2.1]"
ol.AddAfter docB, docC ' AddAfter 1st element [1.3]
' we should have B, C, A with C the current item.
ListIs ol, "B,C,A", "C", 1, "[1.3] [1.6]"

Dim docD As NotesDocument
Set docD = ol.get(-1) ' [8.2]
If Not (docD Is Nothing) Then Error 99, "[8.2]"
Set docD = ol.get(3) ' [8.3]
If Not (docD Is Nothing) Then Error 99, "[8.3]"

Set docD = newDoc("D")
ol.AddAt 3, docD ' B,C,A,D AddAt end [2.2]
ListIs ol, "B,C,A,D", "D", 3, "[2.2] [2.6]"
Dim docE As NotesDocument
Set docE = newdoc("E")
ol.AddAt 2, docE ' B,C,E,A,D AddAt middle [2.3]
ListIs ol, "B,C,E,A,D", "E", 2, "[2.3] [2.6]"

Dim docF As NotesDocument
Set docF = newDoc("F")
ol.AddAfter docC, docF ' AddAfter middle element [1.5]
Dim docG As NotesDocument
Set docG = newDoc("G")
ol.AddAfter docD, docG ' AddAfter last element [1.4]
ListIs ol, "B,C,F,E,A,D,G", "G", 6, "[1.4] [1.6]"
If getIDsFL(ol) <> "B,C,F,E,A,D,G" Then Error 99, "test 5b-FL (" & getIDsFL(ol) & ")"
If getIDsBL(ol) <> "B,C,F,E,A,D,G" Then Error 99, "test 5c-BL (" & getIDsBL(ol) & ")"

ol.Append newDoc("H") ' [3.2]
ListIs ol, "B,C,F,E,A,D,G,H", "H", 7, "[3.2] [3.3]"
Dim docH As NotesDocument
Set docH = ol.current
If docH.id(0) <> "H" Then Error 99, "After Append"

Dim docI As NotesDocument
Set docI = newDoc("I")
expectErr = True
ol.AddAt -1, docI
If expectErr Then Error 99, "[2.4]"
expectErr = True
ol.AddAt 9, docI
If expectErr Then Error 99, "[2.5]"

Dim docJ As NotesDocument
Set docJ = newDoc("J")
expectErr = True
ol.AddAfter docI, docJ
If expectErr Then Error 99, "[1.2]"
expectErr = True
ol.AddAfter Nothing, docJ
If expectErr Then Error 99, "[1.1]"

' now start removing things.
ol.Remove docI ' it is not in the list, but in that case, doing nothing matches the intent!
ol.Remove docB
ListIs ol, "C,F,E,A,D,G,H", "C", 0, "[14.2]"
If Not ol.Prev Is Nothing Then Error 99, "[14.2] Prev not nothing"
ol.Remove docH
ListIs ol, "C,F,E,A,D,G", "G", 5, "[14.3]"
If Not ol.Next Is Nothing Then Error 99, "[14.3] Next not nothing"
ol.Remove docE
ListIs ol, "C,F,A,D,G", "A", 2, "[14.4]"

' removeAt tests
expectErr = True
ol.RemoveAt -1
If expectErr Then Error 99, "[15.1]"
expectErr = True
ol.RemoveAt 5
If expectErr Then Error 99, "[15.2]"
ol.RemoveAt(1)
ListIs ol, "C,A,D,G", "A", 1, "[15.5]"
ol.RemoveAt(3)
ListIs ol, "C,A,D", "D", 2, "[15.4]"
Stop
ol.RemoveAt(0)
ListIs ol, "A,D", "A", 0, "[15.3]"
If Not ol.Prev Is Nothing Then Error 99, "[15.x] Prev not nothing"
ol.Position = 1
If Not ol.Next Is Nothing Then Error 99, "[15.x] Next not nothing"

Delete ol
If docA Is Nothing Or docD Is Nothing Then Error 99, "[6] [11.2]"

Set ol = New ObjectList
ol.OwnObjects = True

ol.RemoveCurrent ' [16.1]: don't bug me if I remove when nothing's there.

ol.AddAt 0, docA
ListIs ol, "A", "A", 0, "[2.7]"
If getIDsFL(ol) <> "A" Then Error 99, "[2.1] FL"
If getIDsBL(ol) <> "A" Then Error 99, "[2.1] BL"

ol.Append docB
ol.Append docC
ol.Append docD
ol.Append docE
ol.Append docF
ol.Append docG
ol.Append docH
ListIs ol, "A,B,C,D,E,F,G,H", "H", 7, "After appending several"

stop
expectErr = true
If ol.RepositionTo(docI) Then
Error 99, "[17.9]"
End If
If Not ol.RepositionTo(docA) Then Error 99, "[17.1](a)"
CurrentIs ol, "A", 0, "[17.1](b)"
If Not ol.RepositionTo(docH) Then Error 99, "[17.2](a)"
CurrentIs ol, "H", 7, "[17.2](b)"
If Not ol.RepositionTo(docE) Then Error 99, "[17.3](a)"
CurrentIs ol, "E", 4, "[17.3](b)"
If Not ol.RepositionTo(docE) Then Error 99, "[17.8](a)"
CurrentIs ol, "E", 4, "[17.8](b)"
If Not ol.RepositionTo(docF) Then Error 99, "[17.4](a)"
CurrentIs ol, "F", 5, "[17.4](b)"
If Not ol.RepositionTo(docD) Then Error 99, "[17.5](a)"
CurrentIs ol, "D", 3, "[17.5](b)"
If Not ol.RepositionTo(docF) Then Error 99, "[17.6](a)"
CurrentIs ol, "F", 5, "[17.6](b)"
If Not ol.RepositionTo(docE) Then Error 99, "[17.7](a)"
CurrentIs ol, "E", 4, "[17.7](b)"

ol.RemoveCurrent
ListIs ol, "A,B,C,D,F,G,H", "F", 4, "[16.4]"
ol.Position = 0
ol.RemoveCurrent
ListIs ol, "B,C,D,F,G,H", "B", 0, "[16.2] [13.3]"
ol.Position = 5
ol.RemoveCurrent
ListIs ol, "B,C,D,F,G", "G", 4, "[16.2] [13.4]"
ol.Position = 2
ListIs ol, "B,C,D,F,G", "D", 2, "[13.5]"
expectErr = True
ol.Position = -1
If expectErr Then Error 99, "[13.1]"
expectErr = True
ol.Position = 5
If expectErr Then Error 99, "[13.2]"

MsgBox "Success!"
Exit Sub
oops:
If expectErr And Err <> 99 Then
expectErr = False ' that would be a pass
Resume Next
End If
MsgBox "Error on line " & Erl & ": " & Error
Exit sub

End Sub


'++LotusScript Development Environment:2:1:getIDs:6:8
%REM
Function getIDs
Description: Return a comma-delimited list of the IDs of documents in the list.
Also tests [8.1] - each valid index for Get and [4] - that Count works
%END REM
Function getIDs(ol As ObjectList) As string
If ol.Count Then
getIDs = ol.get(0).ID(0)
Dim i%
For i = 1 To ol.Count - 1
getIDs = getIDs & "," & ol.get(i).ID(0)
Next
End If
End Function

'++LotusScript Development Environment:2:2:CurrentIs:5:8
%REM
Sub CurrentIs
Description: Assert that the current list entry is position 'pos', with ID 'id'
%END REM
Sub CurrentIs(ol As ObjectList, ByVal id$, ByVal pos As Long, ByVal testID$)
If ol.Position <> pos Then
Error 99, "Expected Position=" & pos & ", actual " & ol.Position
End If

Dim doc As NotesDocument, actual$
Set doc = ol.Current
If Not (doc Is Nothing) Then
actual = doc.ID(0)
End If
If actual <> id Then
Error 99, testID$ & " Expected current doc '" & id & "', actual '" & actual & "'"
End If
End Sub


'++LotusScript Development Environment:2:1:newDoc:6:8
%REM
Function newDoc
Description: Create a new NotesDocument object with a field value that lets us
identify it later.
%END REM
Function newDoc(ByVal ID$) As NotesDocument
Set newDoc = db.Createdocument
newDoc.ID = ID
End Function


'++LotusScript Development Environment:2:1:getIDsFL:6:8
%REM
Function getIDsFL
Description: Return a comma-delimited list of the IDs of documents in the list,
By using First and Next properties. Also tests [10.2], [7.2]
%END REM
Function getIDsFL(ol As ObjectList) As String
Dim doc As NotesDocument
Set doc = ol.First
Do Until doc Is Nothing
getIDsFL = getIDsFL & "," & doc.ID(0)
Set doc = ol.Next
Loop
getIDsFL = Mid$(getIDsFL, 2)
End Function

'++LotusScript Development Environment:2:2:ListIs:5:8
%REM
Sub ListIs
Description: Assert the list contents and current element
%END REM
Sub ListIs(ol As objectList, ByVal expected$, ByVal curID$, ByVal pos%, ByVal testID$)
CurrentIs ol, curID, pos, testID$
Dim actual$
actual = getIDs(ol)
If actual <> expected Then
Error 99, testID & " List contents " & actual & ", expected " & expected
End If
If ol.count Then ol.Position = pos
End Sub

'++LotusScript Development Environment:2:1:getIDsBL:6:8
%REM
Function getIDsBL
Description: Return comma-delimited list of the IDs of documents in the list,
By using Last and Prev properties. Also tests [9.2] and [18.2]
%END REM
Function getIDsBL(ol As ObjectList) As String
Dim doc As NotesDocument
Set doc = ol.Last
Do Until doc Is Nothing
getIDsBL = "," & doc.ID(0) & getIDsBL
Set doc = ol.Prev
Loop
getIDsBL = Mid$(getIDsBL, 2)
End Function

'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Agent reordering dialog test
Created Apr 20, 2010 by Andre Guirard/Cambridge/IBM
Description: TODO
%END REM
Option Public
Option Declare
Use "UIHelper"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim ui As New UIHelper(Nothing)
Dim choices
choices = Split("nine,just,sat,mother,my,very,porcupines,elegant,upon", ",")
Dim result As Boolean

result = ui.ReorderChoicesDialog("Dialog test", _
"Please use the buttons to reorder the list into your desired sequence.", Choices, "")
If result Then
MsgBox "New order: " & Join(choices, {, })
End If

End Sub
'++LotusScript Development Environment:2:5:(Options):0:72
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 'Create Attachment Sample'
Created Aug 7, 2009 by Andre Guirard/Cambridge/IBM
Description: A simple example of the use of the AttachmentAdder and Image classes.
Creates a document with a couple of attachments.
%END REM
Option Public
Option Declare
Use "AttachmentAdder"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:10

' To make things simpler, hardcoded base64 GIF image.
Const R_IN_CIRCLE = {R0lGODlhIAAvAOYAAIAAgIAAhIAAiJcAgIAAl4AjgIA6gIAAr4BggIBwgMRIgNh0gAD//wH//wL/
/wP//wT//wb//wf//w7//w///xT//xf//xn//x3//yD//yL//yf//yj//yn//y3//y7//zL//z7/
/z///0D//0P//0T//0j//1X//17//2P//2v//27//3T//3f//37//4CAgJeAgICAl4CAr8SXgOyS
h+ycl9ivgMScr/+/r+zEl8TEr//Yr4CXxICv2IyQ7Jec7JfE7K/Y/4X//4z//53//57//5///6D/
/6b//6f//6v//6z//7H//7b//7f//7n//8TPxP/sxMTf/8Ts/8b//8j//8v//9L//9X//9f//9j/
/9z//93//9//////7OH//+f//+r//+z///T///X///b///f///z///3///7//////wAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwA
AAAAIAAvAAAI/gDVCBxI8EyVFiM2ZMiwYUSLKmcISpxIEMsJCgwyasxI4QQWiiAFIrHAAMMKJ1m6
dMniZAUGBhaQhJw4BEKDFFvSTEyzJUUDCENmDhzyswiamWiK2Aw6MwkECEuEDlzyNEnIKxUaFJFK
sEiDClcoliHBQIVOrgLTqGBAoszEIw88hEFLMIyHB0ckivkAQQldiUogfBBD0IgDEWP+EhwjwoGR
gWRGPLAqEQcAAlIGWgYA4AfBJA9GkBFIZUIHMAO9KOB8ObNq1pw9CwTTYQIVgS4YrNC5GTbm17AB
HNCSdgUDF2rGhJDQRE2N4JwxL4AunLjAJhJCjMlyQcMXgsAv/t8AYCAGlAGsC7x4AUTNFw0XsjCJ
YMKMxOewDbyIMQX4+vVAmGFCBEwI0QALZ2kGm3r79TfDf//JkAULDQiBAgNETEQDbAisx58NEEao
BREMoFACA09M1BsACXiowws9qBEFDP/xIMYTDJQAAgNWqMhaAC3+F6NAXjwoA3FWMAACBwxk4SNn
AgT5go0hZcEABxowwMWTAET5XxAzccGABhkw0AWXXjY4UxcMZJDllpWxliZ/YY7JpJNxQhkknVVe
uWOPeXa55xQzJQnCiSkGOiehIeFYwoUZKjroTCSiYCCCknrIKEVpUCjEfPVlqiZIAhLInXei8knR
e/Epx1ygqAB0OCpF2GmnRm67ETQda/rNKlEaxiGnRmmnDYTfgr4SRJttAkU22YrUAeADSKCJNpBh
iFG0A4RgTsSYYwTt1RdFIApJUWCDSQSXXBLlEOKUhA1kF14TjVWWTtu+G2J7arHl1kRYafWXV2CF
5BRUaFEFAWUhEQWBUUgp1QBTQtV0U0479fQTxVKNVNJJKa3U0ksxKWYRRhtp1NFHiqlhEEIKMeQQ
RDMFBAA7}


'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
On Error GoTo oops
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Set db = session.Currentdatabase
Set doc = db.Createdocument
' first set other fields -- the attachment manipulation should be the last step.
doc.replaceitemvalue "Form", "Sample"
doc.Replaceitemvalue "Subject", "AttachmentAdder / 1. Create Attachments at " & Now
doc.Replaceitemvalue("Author", session.Username).Isauthors = True
doc.Replaceitemvalue "Expiration", Now+30
Dim aa As New AttachmentAdder(doc, False)
If Not (doc Is Nothing) Then
MsgBox "Something's wrong; doc object was not deleted." ' aa owns the document now; the caller shouldn't still have it.
End if
aa.LoadIcon Db, "rt-doc.gif" ' set the icon for file attachments from an image resource.
Dim stream As NotesStream
Set stream = session.Createstream ' default unicode stream (only kind we can get without using a file!)
stream.Writetext "First we'll create a regular MSDOS text file. This is line 1.", EOL_CRLF
stream.Writetext "This is line 2.", EOL_CRLF
stream.Writetext "The End", EOL_CRLF

' creating the attachment is a two-step process. First attach to the document, then create a reference to it in the rich text field.
aa.AddDocAttachTextStream stream, "US-ASCII", "little.txt" ' text is converted to the specified character set.
aa.AppendRTAttach "little.txt", "little.txt", "Body" ' if you want a "v2 style" attachment, leave this off.

' next, let's attach an image file. Just because we already have the code for it, I'll
' get the images from another image resource, but they could be generated by code or
' whatever.
Dim lionAndUnicorn As New Image
lionAndUnicorn.LoadImageResource db, "lionUni.jpg"
aa.LoadIcon Db, "lionUniThumb.jpg" ' a thumbnail can be the attachment icon, if you happen to have one available.
aa.AddDocAttachBase64 lionAndUnicorn.Base64, "lionUni.jpg"
aa.AppendRTAttach "lionUni.jpg", "lionUni.jpg", "Body"

' just for giggles, we'll also insert a hardcoded picture (with no attachment) into the rich text item.
Dim circul_r As New Image
circul_r.SetBase64 "gif", R_IN_CIRCLE
Dim rtiNode As NotesDOMElementNode, domd As NotesDOMDocumentNode, par As NotesDOMElementNode
Set rtiNode= aa.getRTItem("Body")
Set domd = aa.DOMDoc
Set par = aa.getLastPar(rtiNode)
par.Appendchild circul_r.createPictureElement(domd)

' there's no way to get your changes into a Notes document without saving the note.
If aa.Save = "" Then
MsgBox "Save failed: " & aa.Log
End If
Exit Sub
oops:
MsgBox "Error " & Err & ": " & Error & " //Initialize:" & Erl
Exit sub
End Sub
'++LotusScript Development Environment:2:5:(Options):0:72
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 'Create Attachment Sample with Image Resource as Icon'
Created Aug 7, 2009 by Andre Guirard/Cambridge/IBM
Description: A simple example of the use of the AttachmentAdder and Image classes.
Creates a document with a couple of attachments.
%END REM
Option Public
Option Declare
Use "AttachmentAdder"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:10



'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
On Error GoTo oops
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Set db = session.Currentdatabase
Set doc = db.Createdocument
' first set other fields -- the attachment manipulation should be the last step.
doc.replaceitemvalue "Form", "Sample"
doc.Replaceitemvalue "Subject", "AttachmentAdder / 2. Image Resource " & Now
doc.Replaceitemvalue("Author", session.Username).Isauthors = True
doc.Replaceitemvalue "Expiration", Now+30
Dim aa As New AttachmentAdder(doc, False)
If Not (doc Is Nothing) Then
MsgBox "Something's wrong; doc object was not deleted." ' aa owns the document now; the caller shouldn't still have it.
End if
aa.LoadIcon Db, "rt-doc.gif" ' set the icon for file attachments from an image resource.
aa.Icon.PreserveRef = True ' put image resource reference into docs instead of copy of image.

Dim stream As NotesStream
Set stream = session.Createstream ' default unicode stream (only kind we can get without using a file!)
stream.Writetext "First we'll create a regular MSDOS text file. This is line 1.", EOL_CRLF
stream.Writetext "This is line 2.", EOL_CRLF
stream.Writetext "The End", EOL_CRLF

' creating the attachment is a two-step process. First attach to document, then create reference to it in rich text field.
aa.AddDocAttachTextStream stream, "US-ASCII", "little.txt" ' text is converted to the specified character set.
aa.AppendRTAttach "little.txt", "little.txt", "Body" ' if you want a "v2 style" attachment, leave this off.

' With DXL, only way to get changes into a Notes document involves saving the note.
If aa.Save = "" Then
MsgBox "Save failed: " & aa.Log
End If
Exit Sub
oops:
MsgBox "Error " & Err & ": " & Error & " //Initialize:" & Erl
Exit sub
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 'Substitute Image Into Table'
Created Aug 7, 2009 by Andre Guirard/Cambridge/IBM
Description: A simple example of the use of the AttachmentAdder and Image classes.
Creates a document with a couple of attachments.
%END REM
Option Public
Option Declare
Use "AttachmentAdder"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:10

Const R_IN_CIRCLE = {R0lGODlhIAAvAOYAAIAAgIAAhIAAiJcAgIAAl4AjgIA6gIAAr4BggIBwgMRIgNh0gAD//wH//wL/
/wP//wT//wb//wf//w7//w///xT//xf//xn//x3//yD//yL//yf//yj//yn//y3//y7//zL//z7/
/z///0D//0P//0T//0j//1X//17//2P//2v//27//3T//3f//37//4CAgJeAgICAl4CAr8SXgOyS
h+ycl9ivgMScr/+/r+zEl8TEr//Yr4CXxICv2IyQ7Jec7JfE7K/Y/4X//4z//53//57//5///6D/
/6b//6f//6v//6z//7H//7b//7f//7n//8TPxP/sxMTf/8Ts/8b//8j//8v//9L//9X//9f//9j/
/9z//93//9//////7OH//+f//+r//+z///T///X///b///f///z///3///7//////wAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwA
AAAAIAAvAAAI/gDVCBxI8EyVFiM2ZMiwYUSLKmcISpxIEMsJCgwyasxI4QQWiiAFIrHAAMMKJ1m6
dMniZAUGBhaQhJw4BEKDFFvSTEyzJUUDCENmDhzyswiamWiK2Aw6MwkECEuEDlzyNEnIKxUaFJFK
sEiDClcoliHBQIVOrgLTqGBAoszEIw88hEFLMIyHB0ckivkAQQldiUogfBBD0IgDEWP+EhwjwoGR
gWRGPLAqEQcAAlIGWgYA4AfBJA9GkBFIZUIHMAO9KOB8ObNq1pw9CwTTYQIVgS4YrNC5GTbm17AB
HNCSdgUDF2rGhJDQRE2N4JwxL4AunLjAJhJCjMlyQcMXgsAv/t8AYCAGlAGsC7x4AUTNFw0XsjCJ
YMKMxOewDbyIMQX4+vVAmGFCBEwI0QALZ2kGm3r79TfDf//JkAULDQiBAgNETEQDbAisx58NEEao
BREMoFACA09M1BsACXiowws9qBEFDP/xIMYTDJQAAgNWqMhaAC3+F6NAXjwoA3FWMAACBwxk4SNn
AgT5go0hZcEABxowwMWTAET5XxAzccGABhkw0AWXXjY4UxcMZJDllpWxliZ/YY7JpJNxQhkknVVe
uWOPeXa55xQzJQnCiSkGOiehIeFYwoUZKjroTCSiYCCCknrIKEVpUCjEfPVlqiZIAhLInXei8knR
e/Epx1ygqAB0OCpF2GmnRm67ETQda/rNKlEaxiGnRmmnDYTfgr4SRJttAkU22YrUAeADSKCJNpBh
iFG0A4RgTsSYYwTt1RdFIApJUWCDSQSXXBLlEOKUhA1kF14TjVWWTtu+G2J7arHl1kRYafWXV2CF
5BRUaFEFAWUhEQWBUUgp1QBTQtV0U0479fQTxVKNVNJJKa3U0ksxKWYRRhtp1NFHiqlhEEIKMeQQ
RDMFBAA7}


'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
' On Error GoTo oops
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Set db = session.Currentdatabase
Set doc = db.Createdocument
' first set other fields -- the attachment manipulation should be the last step.
doc.replaceitemvalue "Form", "Sample"
doc.Replaceitemvalue "Subject", "AttachmentAdder / 3. Substitution at " & Now
doc.Replaceitemvalue("Author", session.Username).Isauthors = True
doc.Replaceitemvalue "Expiration", Now+30
Dim rti As New NotesRichTextItem(doc, "Body")
Dim bold As NotesRichTextStyle, nobold As NotesRichTextStyle
Set bold = session.Createrichtextstyle
Set nobold = session.Createrichtextstyle
bold.Bold = -1
nobold.Bold = 0
Call rti.Appendtable(5, 3)
Dim nav As NotesRichTextNavigator
Set nav = rti.Createnavigator
nav.Findfirstelement(RTELEM_TYPE_TABLECELL)
Dim i%
For i = 0 To 14
rti.Begininsert nav
rti.Appendtext "<" & i & ">"
If i = 12 Then
rti.appendStyle bold
rti.Appendtext " twelve!"
rti.Appendstyle noBold
End If
rti.Endinsert
nav.FindNextelement(RTELEM_TYPE_TABLECELL)
Next
rti.Update

Dim aa As New AttachmentAdder(doc, False)
If Not (doc Is Nothing) Then
MsgBox "Something's wrong; doc object was not deleted." ' aa owns the document now; the caller shouldn't still have it.
End If

Dim Ricon As New Image
Dim elPic As NotesDOMElementNode, elRef As NotesDOMElementNode
Ricon.SetBase64 "gif", R_IN_CIRCLE
Dim rtNode As NotesDOMElementNode
Set rtNode = aa.getRTItem("Body")
Set aa.Icon = Ricon

Dim stream As NotesStream
Set stream = session.Createstream ' default unicode stream (only kind we can get without using a file!)
stream.Writetext "Mary had a little beep", EOL_CRLF
stream.Writetext "That came from her Palm Pre,", EOL_CRLF
stream.Writetext "And everywhere that Mary went,", EOL_CRLF
stream.Writetext "The beeping Pre would be.", EOL_CRLF

' attach to the document
aa.AddDocAttachTextStream stream, "US-ASCII", "beep.txt" ' text is converted to the specified character set.
Dim rtiNode As NotesDOMElementNode, domd As NotesDOMDocumentNode
Set rtiNode= aa.getRTItem("Body")
Set domd = aa.DOMDoc

' Use the ReplaceText function to replace the markers in the cells with
' attachments and pictures
ReplaceText rtiNode, "<7>", aa.CreateAttachRef("beep.txt", "beep.txt"), domd
ReplaceText rtiNode, "6", rIcon.CreatePictureElement(Domd), domd
' the reason we call CreatePictureElement repeatedly instead of doing it once and
' saving the value, is that a node can only appear in one place in the tree, so we
' need a new node each time. It would also work to make one call and "clone" the node
' each time.
ReplaceText rtiNode, "8>", rIcon.CreatePictureElement(Domd), domd
ReplaceText rtiNode, "<9", rIcon.CreatePictureElement(Domd), domd
' in the last three calls we left some text behind in the cell also to make sure
' that wouldn't cause a problem.
ReplaceText rtiNode, "<12>", rIcon.CreatePictureElement(Domd), domd
If aa.Save = "" Then
MsgBox "Save failed: " & aa.Log
End If
Exit Sub
oops:
MsgBox "Error " & Err & ": " & Error & " //Initialize:" & Erl
Exit sub
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 'Image Info'
Created Mar 31, 2010 by Andre Guirard/Cambridge/IBM
Description: Sample code for the EmbeddedImage class, this agent locates
a sample data document and displays information about the images in it.
%END REM

Option Public
Option Declare
Use "EmbeddedImage"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim wksp As New NotesUIWorkspace, session As New NotesSession
Dim db As NotesDatabase, vu As NotesView, doc As NotesDocument
Set db = session.Currentdatabase
Set vu = db.Getview("SampleBySubject")
Set doc = vu.Getdocumentbykey("Embedded images test", True)

Dim eil As New EmbeddedImageList(doc)

Const NL = {
}
Dim res$, i As long
res = "Document contains " & eil.Count & " images." & NL

For i = 0 To eil.Count - 1
Dim ei As EmbeddedImage
Set ei = eil.Image(i)
res = res & NL & " - type: " & ei.ImageType & " (" & ei.Width() & " x " & ei.Height & " px)"
Next

MsgBox res

End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 2. Update Image
Created Mar 31, 2010 by Andre Guirard/Cambridge/IBM
Description: An example of the EmbeddedImage class. Locate an image
in a sample document, and replace its any image that's too big with
a preprogrammed smaller image.
%END REM
Option Public
Option Declare
Use "EmbeddedImage"
Use "FileResource"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim wksp As New NotesUIWorkspace, session As New NotesSession
Dim db As NotesDatabase, vu As NotesView, doc As NotesDocument
Set db = session.Currentdatabase
Set vu = db.Getview("SampleBySubject")
Set doc = vu.Getdocumentbykey("Embedded images test", True)

Dim eil As New EmbeddedImageList(doc) ' retrieve the list of rich text images in the doc.
Dim imgTooBig As FileResource, streamTooBig As NotesStream

Dim i As long

For i = 0 To eil.Count - 1
Dim ei As EmbeddedImage
Set ei = eil.Image(i)
If ei.Width > 100 Or ei.Height > 100 Then
' replace the image with a smaller image.
If imgTooBig Is Nothing Then
' the replacement image is in an image resource design element.
' We have another class to help with retrieving its information.
Set imgTooBig = FindFileResource(db, "image", "toobig.gif")
Set streamTooBig = session.Createstream
imgTooBig.ReadFileData streamTooBig
End If
ei.WriteFromBytes streamTooBig ' update the embedded image.
End If
Next

' if we've had to load the "too big" image, it means the document has
' been modified. Save changes into a new document (so as not to spoil the sample data).
If Not (streamTooBig Is Nothing) Then
' save changes
eil.ImportOption = DXLIMPORTOPTION_CREATE
Set doc = eil.Save(False)
' Because this works by DXL import, the document has already been saved. But
' we wanted to change the subject, so save it again.
doc.Subject = "Embedded images test - Output"
doc.save True, False, True
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 2. Update Image
Created Mar 31, 2010 by Andre Guirard/Cambridge/IBM
Description: An example of the EmbeddedImage class. Locate an image
in a sample document, and replace its any image that's too big with
a preprogrammed smaller image.
%END REM
Option Public
Option Declare
Use "EmbeddedImage"
Use "FileResource"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const NL = {
}

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim wksp As New NotesUIWorkspace, session As New NotesSession
Dim db As NotesDatabase, vu As NotesView, doc As NotesDocument
Set db = session.Currentdatabase
Set vu = db.Getview("SampleBySubject")
Set doc = vu.Getdocumentbykey("Scaled images test", True)

Dim eil As New EmbeddedImageList(doc) ' retrieve the list of rich text images in the doc.

Dim i As Long, desc$
Dim imgTooBig As FileResource, streamTooBig As NotesStream

For i = 0 To eil.Count - 1
Dim ei As EmbeddedImage
Set ei = eil.Image(i)
desc = desc & NL & "Image " & i & ": " & ei.Width & " x " & ei.Height & " px"
If ei.ScaledHeight Then
desc = desc & " scaled to " & format(CDbl(ei.ScaledWidth)/Ruler_one_inch, "0.#####") & {"x} & _
format(CDbl(ei.ScaledHeight)/Ruler_one_inch, "0.#####") & {"}
End If

Select Case i
Case 0
' reset first image to default scaling
ei.ResetScaling
Case 1
' set second image to 200%
ei.ScalePercent = 200
Case 2
' replace the third image, which should reset it to default scaling
If imgTooBig Is Nothing Then
' the replacement image is in an image resource design element.
' We have another class to help with retrieving its information.
Set imgTooBig = FindFileResource(db, "image", "toobig.gif")
Set streamTooBig = session.Createstream
imgTooBig.ReadFileData streamTooBig
End If
ei.WriteFromBytes streamTooBig ' update the embedded image.
Case 3
' the 4th image should be a little taller and narrower.
ei.ScalePercent = 120
ei.ScaledWidth = ei.ScaledWidth * .6667 ' should result in 80% of original width
End Select
Next

MsgBox Mid$(desc, 2), 0, "Image Summary"

' if we've had to load the "too big" image, doc was modified. Save changes into new doc.
If Not (streamTooBig Is Nothing) Then
' save changes
eil.ImportOption = DXLIMPORTOPTION_CREATE
Set doc = eil.Save(False)
' Because this works by DXL import, the document has already been saved. But
' we wanted to change the subject, so save it again.
doc.Subject = "Scaled images test - Output"
doc.save True, False, True
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Agent FileResource - Export Image Resource
Created Mar 8, 2010 by Andre Guirard/Cambridge/IBM
Description: Takes a specific image resource from the current database,
and exports it to a disk file.
%END REM
Option Public
Option Declare
Use "FileResource"
Use "UIHelper"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim session As New NotesSession, wksp As New NotesUIWorkspace
Dim path
Dim db As NotesDatabase
Set db = session.Currentdatabase
Dim ui As New UIHelper(db)

path = ui.SaveFilePrompt("Export Image Resource", "JPG files|*.jpg;*.jpeg", "lionUni.jpg")
If IsEmpty(path) Then Exit Sub

Dim fr As FileResource
Set fr = FindFileResource(db, "image", "lionUni.jpg")
Dim stream As NotesStream
Set stream = session.Createstream
stream.Open path(0), "binary"
stream.Truncate
fr.ReadFileData stream
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Agent FileResource - Change Background Color
Created Mar 8, 2010 by Andre Guirard/Cambridge/IBM
Description: Read a Stylesheet resource design element into memory,
locate the current "body background color", display it to the
user and let them select a new color. Update the design note
with that as the new background color.
%END REM

Option Public
Option Declare
Use "FileResource"
Use "UIHelper"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const NL = {
}

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim session As New NotesSession, wksp As New NotesUIWorkspace
Dim db As NotesDatabase
Set db = session.Currentdatabase
Dim ui As New UIHelper(db)
Dim ssData$

Dim fr As FileResource
Set fr = FindFileResource(db, "stylesheet", "antelope.css")
Dim stream As NotesStream
Set stream = session.Createstream
fr.ReadFileData stream
ssData = streamToText(stream, fr.MimeCharSet)

' now find the background color in this.
Dim parts, i%, bodyInd%, tmp$
parts = Split(ssdata, "{")
For i = 1 To UBound(parts)
tmp = fullTrim(Replace(Replace(Right(parts(i-1), 30), Chr$(13), " "), Chr$(10), " "))
If StrToken(tmp, " ", -1) = "BODY" Then
bodyInd = i
Exit for
End If
Next

If bodyInd = 0 Then
MsgBox "Can't find BODY definition in antelope.css", 0, "Change Background Color"
Exit Sub
End If

Const COLORTAG = {background-color:}
Dim beforeColor$, afterColor$, color$, oldColor$, pos As Long, epos As long
pos = InStr(parts(bodyInd), COLORTAG)
If pos = 0 Then
MsgBox "Can't find '" & COLORTAG & "' in BODY definition of antelope.css", 0, "Change Background Color"
Exit Sub
End If
pos = pos + Len(COLORTAG)
epos = InStr(pos, parts(bodyInd), ";")
If epos = 0 Then epos = InStr(pos, parts(bodyInd), "}")
oldColor = Trim(Mid$(parts(bodyInd), pos, epos-pos))

color = ui.GetColor("Screen Background", oldColor)
If color = "" Or StrComp(color, oldColor, 1) = 0 Then Exit Sub

parts(bodyInd) = Left$(parts(bodyInd), pos-1) & " " & color & Mid$(parts(bodyInd), epos)
ssData = Join(parts, "{")

Set stream = texttostream(ssData, fr.MimeCharSet)
fr.UpdateFileData stream
If fr.Save Then
MsgBox "Stylesheet update succeeded"
Else
MsgBox fr.Log
End If

End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Agent FileResource - Update XPage
Created Mar 8, 2010 by Andre Guirard/Cambridge/IBM
Description: Read an XPage design element, extract out the contents
(which are XML). Parse the contents with a DOM parser and find an
element we want to change, replace a string in that element, and
then reimport the XML as the new XPage contents.
%END REM
Option Public
Option Declare
Use "FileResource"
Use "UIHelper"
Use "TempFolderManager"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const NL = {
}

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim session As New NotesSession, wksp As New NotesUIWorkspace
Dim db As NotesDatabase
Dim tfm As New TempFolderManager("AG")
Set db = session.Currentdatabase

Dim fr As FileResource
Set fr = FindFileResource(db, "xpage", "SimpleView.xsp")
Dim streamIn As NotesStream, streamOut As NotesStream
Set streamIn = session.Createstream
Set streamOut = session.Createstream

' Hack to prevent the Serialize method using an arbitrary character set for
' export: connect to a file using UTF-8.
Call streamOut.Open(tfm.CreateFilename("xsp", true), "UTF-8")
fr.ReadFileData streamIn

Dim domp As NotesDOMParser, domd As NotesDOMDocumentNode, dnl As NotesDOMNodeList
Dim elLabel As NotesDOMElementNode, i%
Set domp = session.Createdomparser(streamIn, streamOut)
domp.Process
Set domd = domp.Document
Set dnl = domd.Getelementsbytagname("xp:label")
For i = 1 To dnl.Numberofentries
Set elLabel = dnl.Getitem(i)
If elLabel.Getattribute("id") = "Sponsor" Then
Exit for
End If
Next

If i > dnl.Numberofentries Then
MsgBox "Label for 'Sponsor' not found in XPage.", 0, "Update XPage"
Exit Sub
End If

Dim newLabel$
newLabel = InputBox("Enter new sponsor:", "Update XPage", elLabel.Getattribute("value"))
If newLabel = "" Then Exit Sub

elLabel.Setattribute "value", newLabel
domp.Serialize

fr.UpdateFileData streamOut
If fr.Save Then
MsgBox "XPage update succeeded"
Else
MsgBox fr.Log
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent 'Replicate Pirates'
Description: An example showing how to do one-way synchronization
between two data sources using the LC LSX. This was originally
published in the "Dick Tracy" sample in the Lotus Sandbox.
%END REM

Option Public
Option Declare
Uselsx "*lsxlc"
Use "DECSDatabase"
Use "DebugStrLC"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class MessageCollector ' @@@
Declare Sub Initialize
Declare Function LoadConnection(Byval strConnectionName As String, _
Byval strMetadata As String) As LCConnection
Declare Function ArrayStrRightBack(varDataArray, Byval strSearchFor As String) As Variant
Declare Function FieldlistCompare( _
fl1 As LCFieldList, Byval intIndex1 As Integer, _
fl2 As LCFieldList, Byval intIndex2 As Integer, Byval intFlags As Integer) As Integer
Declare Sub SetFieldFlags(fl As LCFieldList, Byval strKeyFields As String, Byval lngFlags As Long)
Declare Function ArrayStrLeft(varDataArray, Byval strSearchFor As String) As Variant

'++LotusScript Development Environment:2:5:(Declarations):0:10
' WARNING: with some versions/connectors, entering a Selection may make an update overwrite all records
' in the target table. Be sure to test on a sample data set first; if this is a problem, change the update to use
' key fields instead of writeback.

Const WRITEBACK_OK = True

Const SOURCE_CONNECTION = "notes-Pirates" ' ' ' enter connection name here
Const SOURCE_METADATA = "" ' ' ' enter metadata here to override metadata in connection doc.
Const SOURCE_SELECTION = "" ' ' ' enter selection expression here to override default (all records)

Const TARGET_CONNECTION = "PiratesDB"
Const TARGET_METADATA = ""
Const TARGET_SELECTION = "" ' ' ' enter selection expression here to override default (all records)

' We're assuming the Notes connection references a view that's sorted by the key field(s)
' listed below.

Const KEY_MAPPING = _
{ID=CustomerID} ' ' ' key fieldnames equivalancies one per line.

Const DATA_MAPPING = _
{Name=ContactNotesID} ' ' ' data fieldname equivalancies one per line.

' three flags that tell whether it's OK to insert, update, and delete target records.
Const INSERT_ENABLED = True
Const UPDATE_ENABLED = True
Const DELETE_ENABLED = True

Const NEWLINE = {
}

Const ACTION_NONE = 0
Const ACTION_INSERT = 1
Const ACTION_UPDATE = 2
Const ACTION_DELETE = 3
Dim msg As MessageCollector ' @@@ = Debugging/Demo code

Class MessageCollector ' @@@
Private messages As String
Private count As Integer
Private limit As Integer

Sub new(Byval intLimit As Integer)
limit = intLimit
End Sub

Sub Print(Byval strMessage As String)
If count = 0 Then
messages = strMessage
Else
messages = messages & NEWLINE & strMessage
End If
count = count + 1
If count >= limit Then Display
End Sub

Sub Display
If count > 0 Then
count = 0
Msgbox messages, 0, ""
End If
End Sub

Sub Delete
Display
End Sub
End Class
'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
%REM
Written 2 Oct 03 by Andre Guirard

This agent does more or less the same thing as the "primary key" Replication activity of
LEI. Given two connection documents, lists of key fields and non key fields (defined as
constants in the Declarations section) this agent reads sorted records from both
connections, compares their field values, and moves data from source to target to make
them the same.

This is designed to run either as a LEI scripted activity, or scheduled.
%END REM

MsgBox {The 'LotusScript Gold Collection' database doesn't contain the data this agent is using to synchronize; this agent is just a code sample.}
Exit Sub

Dim lcses As LCSession

' so that this can be run as either a scheduled agent or scripted activity, try to create a session
' with a name; if that fails, create one with no name.
'On Error Resume Next
'Set lcses = New LCSession("Replicate Customers")
'On Error Goto errortrap
If lcses Is Nothing Then Set lcses = New LCSession

Dim lcconSource As LCConnection, lcconTarget As LCConnection

Dim strSrcKeys As String, strTargKeys As String ' key fieldnames
Dim strSrcData As String, strTargData As String ' data fieldnames
Dim varTempArray As Variant
Dim flSource As New LCFieldList, flTarget As New LCFieldList
Dim flSrcKeys As New LCFieldList, flTargKeys As New LCFieldList
Dim flSrcData As New LCFieldList, flTargData As New LCFieldList
Dim flOutput As New LCFieldList
Dim lngSrcCount As Long, lngTargCount As Long
Dim intAction As Integer, intResult As Integer
Set msg = New MessageCollector(20) ' @@@ = Debugging/Demo code

varTempArray = Split(KEY_MAPPING, NEWLINE)
strSrcKeys = Join(ArrayStrLeft(varTempArray, "="), ",")
strTargKeys = Join(ArrayStrRightBack(varTempArray, "="), ",")

varTempArray = Split(DATA_MAPPING, NEWLINE)
strSrcData = Join(ArrayStrLeft(varTempArray, "="), ",")
strTargData = Join(ArrayStrRightBack(varTempArray, "="), ",")

' Load up the two database connections
Set lcconSource = LoadConnection(SOURCE_CONNECTION, SOURCE_METADATA)
lcconSource.Connect
Set lcconTarget = LoadConnection(TARGET_CONNECTION, TARGET_METADATA)
lcconTarget.Mapbyname = True ' for updates, inserts, use fieldname rather than position.
lcconTarget.Writeback = WRITEBACK_OK
lcconTarget.Connect

' Select the documents from each side.
lcconSource.Ordernames = strSrcKeys
lcconSource.Condition = SOURCE_SELECTION
Call lcconSource.Select(Nothing, 1, flSource)

lcconTarget.Ordernames = strTargKeys
lcconTarget.Condition = TARGET_SELECTION
Call lcconTarget.Select(Nothing, 1, flTarget)

' create the fieldlists that contain just the key fields and just the data fields.
Call flSrcKeys.Map(flSource, strSrcKeys)
Call flSrcData.Map(flSource, strSrcData)
Call flTargKeys.Map(flTarget, strTargKeys)
Call flTargData.Map(flTarget, strTargData)

' make a fieldlist that contains the target fieldnames and the source field objects, for inserts and updates.
Call flOutput.MapName(flSource, strSrcKeys & {,} & strSrcData, strTargKeys & {,} & strTargData)
If Not WRITEBACK_OK Then
' set the key flags on the key fields so that update will only update the one record.
Call SetFieldFlags(flOutput, strTargKeys, LCFIELDF_KEY)
End If

' Prime the pump by fetching one record from each result set.
lngSrcCount = lcconSource.Fetch(flSource)
lngTargCount = lcconTarget.Fetch(flTarget)
Do While lngSrcCount Or lngTargCount
' Decide what to do -- update target, insert target, delete target, or do nothing
intAction = ACTION_NONE
If lngTargCount = 0 Then
' there are no more target records, so obviously there's none to match the current source record.
intAction = ACTION_INSERT
Elseif lngSrcCount = 0 Then
' there are no more source records, so the current target record doesn't have a match.
intAction = ACTION_DELETE
Else
' Which comes "before" the other, the source keys or target keys?
intResult = FieldlistCompare(flSrcKeys, 1, flTargKeys, 1, 0)
Select Case intResult
Case -1
' the source record comes before the dest record -- insert the source record.
intAction = ACTION_INSERT
Case 0
' equal keys -- compare data to see whether an update is necessary.
If UPDATE_ENABLED Then
intResult = FieldlistCompare(flSrcData, 1, fltargData, 1, 0)
If intResult <> 0 Then intAction = ACTION_UPDATE
End If
Case 1
intAction = ACTION_DELETE
End Select
End If

Select Case intAction
Case ACTION_DELETE
If DELETE_ENABLED Then
lcconTarget.Remove flTarget
msg.Print "Removed: " & debugStrLC(flTarget, true) ' @@@
End If
lngTargCount = lcconTarget.Fetch(flTarget)
Case ACTION_UPDATE
' UPDATE_ENABLED has already been checked...
lcconTarget.Update flOutput
msg.Print "Updated: " & debugStrLC(flOutput, true) ' @@@
lngTargCount = lcconTarget.Fetch(flTarget)
lngSrcCount = lcconSource.Fetch(flSource)
Case ACTION_INSERT
If INSERT_ENABLED Then
lcconTarget.Insert flOutput
msg.Print "Inserted: " & debugStrLC(flOutput, true) ' @@@
End If
lngSrcCount = lcconSource.Fetch(flSource)
Case ACTION_NONE
' don't update current record, but source and target have same keys, so
' go to next records in each result set.
lngTargCount = lcconTarget.Fetch(flTarget)
lngSrcCount = lcconSource.Fetch(flSource)
End Select
Loop
lcconTarget.Action LCACTION_COMMIT ' avoid dangling transactions.
Exit Sub

errortrap:
Msgbox "Error " & Err & ": " & Error & " // Initialize:" & Erl, 0, "Replicate Pirates"
Exit Sub
End Sub

'++LotusScript Development Environment:2:1:LoadConnection:2:8
Function LoadConnection(Byval strConnectionName As String, _
Byval strMetadata As String) As LCConnection
%REM
Given a connection document name, creates a LCConnection object from that document.
This is the same as the "New LCConnection" method, but in addition loads metadata
and owner properties.
%END REM
On Error Goto Repeater
Dim doc As NotesDocument
Dim strTemp As String
Static SobjDecsDB As DECSDatabase

If SobjDecsDB Is Nothing Then
Set SobjDecsDB = New DECSDatabase("bobbity", "decsadm.nsf")
' NOTE: your server name here instead of "bobbity".
End If

On Error ErrAdtCreateError Goto ManualLoad
' Try to load the connection using the LCConnection constructor first.
' A connection loaded this way may have multiple levels of metaconnection;
' DECSDatabase cannot manage this. If this fails, we have DECSDatabase as a fallback.
Set LoadConnection = New LCConnection(strConnectionName)
AssignMetadata:
If LoadConnection Is Nothing Then
If strMetadata = "" Then
Set doc = SobjDecsDB.getConnectionDoc(strConnectionName)
LoadConnection.metadata = doc.Metadata(0)
Else
LoadConnection.metadata = strMetadata
End If
LoadConnection.Owner = doc.Ownername(0)
End If
Exit Function

ManualLoad:
On Error Goto Repeater
Set LoadConnection = SobjDecsDB.GetConnection(strConnectionName)
Resume AssignMetadata
Repeater:
Error Err, Error & " // LoadConnection:" & Erl
End Function

'++LotusScript Development Environment:2:1:ArrayStrRightBack:1:8
Function ArrayStrRightBack(varDataArray, Byval strSearchFor As String) As Variant
' Process each element of a string array, looking for the part of the string
' following the last occurrence of a given search string. Return a new array
' containing the resulting values.
' Arguments:
' varDataArray: an array of strings. The contents are not altered.
' strSearchFor: the string we will search for in each array element.
' Result: array with the same dimensions as varDataArray.
Dim intIndex As Integer
Redim strResult(Lbound(varDataArray) To Ubound(varDataArray)) As String
For intIndex = Lbound(varDataArray) To Ubound(varDataArray)
strResult(intIndex) = Strrightback(varDataArray(intIndex), strSearchFor)
Next
ArrayStrRightBack = strResult
End Function

'++LotusScript Development Environment:2:1:FieldlistCompare:3:8
Function FieldlistCompare( _
fl1 As LCFieldList, Byval intIndex1 As Integer, _
fl2 As LCFieldList, Byval intIndex2 As Integer, Byval intFlags As Integer) As Integer
%REM
Written 2 Oct 03 by Andre Guirard

Given two fieldlists with corresponding fields at the same positions, this function tests them
to see whether they contain equal values. One of the following values is returned:

-1 fl1 comes "before" fl2.
0 the lists are equal.
1 fl2 comes "before" fl1.

E.g. if fl1 contains the number 8 and string "howdy", and fl2 contains 8 and "cowboy", returns 1.
%END REM
On Error Goto Repeater
Dim fldFrom1 As LCField, fldFrom2 As LCField
Dim intFieldCount As Integer
Dim intLoopInd As Integer

intFieldCount = fl1.FieldCount
If intFieldCount <> fl2.FieldCount Then
Error LCFAIL_INVALID_FIELDLIST, "FieldlistCompare cannot compare fieldlists of different lengths."
End If

For intLoopInd = 1 To intFieldCount
Set fldFrom1 = fl1.GetField(intLoopInd)
Set fldFrom2 = fl2.GetField(intLoopInd)
FieldlistCompare = fldFrom1.Compare(intIndex1, fldFrom2, intIndex2, 1, _
intFlags)
If FieldlistCompare Then Exit Function
Next
' if FieldlistCompare is never set to a value other than 0 above, return 0.
Exit Function

Repeater:
Error Err, Error & " // FieldlistCompare:" & Erl
End Function


'++LotusScript Development Environment:2:2:SetFieldFlags:1:8
Sub SetFieldFlags(fl As LCFieldList, Byval strKeyFields As String, Byval lngFlags As Long)
' Given a fieldlist, a list of fieldnames (comma delimited) and a flag value,
' sets the specified flags in each of the named fields. The values are "or"ed
' with any flag value already present in the field.
Dim varKeynameArray As Variant
Dim fld As LCField

varKeynameArray = Split(strKeyFields, ",")
Forall strKeyName In varKeynameArray
Set fld = fl.Lookup((strKeyName))
fld.Flags = fld.Flags Or lngFlags
End Forall
End Sub

'++LotusScript Development Environment:2:1:ArrayStrLeft:1:8
Function ArrayStrLeft(varDataArray, Byval strSearchFor As String) As Variant
' Iterates thru an array of strings, searching each for a given string.
' The return value is an array of strings of which each element is the portion of
' the corresponding source element to the left of the first occurrence of the
' search string, or blank if the search string is not found.
' E.g. if varDataArray contains "nothing", "tooth", "chubby" and
' strSearchFor is "th", the return value is "no", too", "".
Redim strResult(Lbound(varDataArray) To Ubound(varDataArray)) As String
Dim intIndex As Integer
For intIndex = Lbound(varDataArray) To Ubound(varDataArray)
strResult(intIndex) = Strleft(varDataArray(intIndex), strSearchFor)
Next
ArrayStrLeft = strResult
End Function


'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

Option Public
Option Declare
Use "ReportGenerator"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:10

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
On Error Goto oops
Dim wksp As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Set uidoc = wksp.CurrentDocument
Dim uirep As New ReportGenerator(DISPLAYTYPE_DIALOG, "", "", Nothing)
uirep.AddReportTitle "Sample Report Output", "Let's see how it looks"
uirep.AddLine "Line 1", False
uirep.AddLine "Line 2", False
uirep.AddParagraphStyle RGENpstyleIndent
uirep.AddLine "2a. Here is a rather long indented line dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky dorky.", False
uirep.AddLine "2b. Another indented line.", True
uirep.AddParagraphStyle RGENpstyleLeft
uirep.AddLine "Line 3", False

Dim dbmail As New NotesDatabase("", "")
dbmail.OpenMail
uirep.AddLine "Here's a link to your mail file: ", False
uirep.AddLink dbmail, "", ""
uirep.AddText "Another kind of link: "
uirep.AddLink dbmail, "", "click here for mail database"
uirep.Display
Exit Sub
oops:
Msgbox "Error " & Err & ": " & Error & "/Sample Report:Initialize:" & Erl
Exit Sub
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

Option Public
Option Declare
Use "ReportGenerator"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const REPORTFORM = "Report" ' or "CSSReport" to use the stylesheet, which at the moment has nothing much interesting in it.

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim rgen As New ReportGenerator(DISPLAYTYPE_TAB, REPORTFORM, "", Nothing)
Dim db As New NotesDatabase("", "")
db.OpenMail
Dim ncoll As NotesNoteCollection
Set ncoll = db.CreateNoteCollection(False)
ncoll.SelectViews = True
' ncoll.SelectFolders = True
ncoll.BuildCollection

rgen.AddReportTitle "View Item Report", "Notes Mail File"
Dim i%, strID$, docDes As notesdocument
strID = ncoll.GetFirstNoteId
While strID <> "" And i < 3
i = i + 1
Set docDes = db.GetDocumentByID(strID)
rgen.AddParagraphStyle RGENpstyleLeft
rgen.AddLine docDes.GetItemValue("$TITLE")(0), False
rgen.AddParagraphStyle RGENpstyleIndent
Forall item In docDes.Items
rgen.AddLine item.Name, False
End Forall
strID = ncoll.GetNextNoteId(strID)
Wend
rgen.Display
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

Option Public
Option Declare
Use "ReportGenerator"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize
Declare Function SpellOutNumber(Byval x As Long) As String

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim rows%
rows = 300
Dim rgen As New ReportGenerator(DISPLAYTYPE_TAB, "", "", Nothing)
rgen.AutoDisplay = True
rgen.AddReportTitle "Table Test Report", rows & " rows"
' the next line assumes you have a Page design element called "Table ViewReport"
' containing a blank table to be imported and filled in, and another called
' "Table ViewReport2", containing the 'continuation' table to be used if the report
' exceeds 255 rows.
rgen.AddTableFromPage rows+1, "Table ViewReport", "Table ViewReport2"
rgen.AdvanceCell 3 ' skip header row, which is already filled in in this case.
Dim i%
For i = 1 To rows
rgen.AddText SpellOutNumber(i)
rgen.NextCell
rgen.AddText Cstr(i)
rgen.NextCell
Next
rgen.Display
End Sub

'++LotusScript Development Environment:2:1:SpellOutNumber:1:8
Function SpellOutNumber(Byval x As Long) As String
If x = 0 Then
SpellOutNumber = "zero"
Exit Function
End If

Dim strParts$
If x >= 1000000000 Then
strParts = SpellOutNumber(x \ 1000000000) & " billion"
x = x Mod 1000000000
End If

If x >= 1000000 Then
strParts = strParts & " " & SpellOutNumber(x \ 1000000) & " million"
x = x Mod 1000000
End If

If x >= 2000 Then
strParts = strParts & " " & SpellOutNumber(x \ 1000) & " thousand"
x = x Mod 1000
End If

Dim BigOnes(9) As String
Dim SmallOnes(19) As String

'and populate them
BigOnes(1) = "ten"
BigOnes(2) = "twenty"
BigOnes(3) = "thirty"
BigOnes(4) = "forty"
BigOnes(5) = "fifty"
BigOnes(6) = "sixty"
BigOnes(7) = "seventy"
BigOnes(8) = "eighty"
BigOnes(9) = "ninety"

SmallOnes(1) = "one"
SmallOnes(2) = "two"
SmallOnes(3) = "three"
SmallOnes(4) = "four"
SmallOnes(5) = "five"
SmallOnes(6) = "six"
SmallOnes(7) = "seven"
SmallOnes(8) = "eight"
SmallOnes(9) = "nine"
SmallOnes(10) = "ten"
SmallOnes(11) = "eleven"
SmallOnes(12) = "twelve"
SmallOnes(13) = "thirteen"
SmallOnes(14) = "fourteen"
SmallOnes(15) = "fifteen"
SmallOnes(16) = "sixteen"
SmallOnes(17) = "seventeen"
SmallOnes(18) = "eighteen"
SmallOnes(19) = "nineteen"

If x >= 100 Then
strParts = strParts & " " & SmallOnes(x \ 100) & " hundred"
x = x Mod 100
End If

Dim div$
If x >= 20 Then
strParts = strParts & " " & BigOnes(x \ 10)
x = x Mod 10
div = "-"
Else
div = " "
End If

If x Then
strParts = strParts & div & SmallOnes(x)
End If

SpellOutNumber = Ltrim(strParts)
End Function
'++LotusScript Development Environment:2:5:(Options):0:72
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent StringDiff\1. Compare sample pages
Created Aug 18, 2009 by Andre Guirard/Cambridge/IBM
Description: Show how to use the StringDiff class to get a list of differences between
the tests on two Page design elements.
%END REM
Option Public
Option Declare
Use "StringDiff"
Use "ReportGenerator"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim db As NotesDatabase
Dim nnc As NotesNoteCollection
Dim docPage As NotesDocument
Dim rti As NotesRichTextItem
Dim str1$, str2$, strID$

Set db = session.Currentdatabase
Set nnc = db.Createnotecollection(False)
nnc.Selectpages = True
nnc.Selectionformula = {@Begins($TITLE; "StringDiffSample")}
nnc.Buildcollection
If nnc.Count <> 2 Then
MsgBox "Failed to find exactly two pages whose names begin with StringDiffSample"
Exit sub
End If
strID = nnc.Getfirstnoteid
Set docPage = db.Getdocumentbyid(strID)
Set rti = docPage.Getfirstitem("$Body")
str1 = rti.Getunformattedtext
strID = nnc.Getnextnoteid(strID)
Set docPage = db.Getdocumentbyid(strID)
Set rti = docPage.Getfirstitem("$Body")
str2 = rti.Getunformattedtext

Dim strdif As New StringDiffer
Dim diffs As DiffResult
Set diffs = strdif.FindDifferences(Str1, Str2)
If diffs.Same Then
MsgBox "strings are the same"
Else
Dim rgen As New ReportGenerator(DISPLAYTYPE_TAB, "", "", Nothing)
Dim dw As New DiffWriterRT(rgen.RtItem)
dw.MaxSegment = 100
dw.WriteDiffs diffs
rgen.Display
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:72
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent StringDiff\2. Two little strings
Created Aug 18, 2009 by Andre Guirard/Cambridge/IBM
Description: Show how to use the StringDiff class with the HTML output option.
%END REM
Option Public
Option Declare
Use "StringDiff"
Use "ReportGenerator"

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim str1$, str2$

str1 = "A big wolf"
str2 = "A bad wolf"

Dim strdif As New StringDiffer
Dim diffs As DiffResult
Set diffs = strdif.FindDifferences(Str1, Str2)

If diffs.Same Then
MsgBox "strings are the same"
Else
Dim dw As New DiffWriterHTML(Nothing)
dw.WriteDiffs diffs
MsgBox dw.HTML
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent StringDiff\3. HTML Table Output
Created Aug 18, 2009 by Andre Guirard/Cambridge/IBM
Description: Show how to use the StringDiff class to get a list of differences between
the tests on two Page design elements and display the results in a table.
%END REM
Option Public
Option Declare
Use "StringDiff"
Use "TempFolderManager"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim db As NotesDatabase
Dim nnc As NotesNoteCollection
Dim docPage As NotesDocument
Dim rti As NotesRichTextItem
Dim str1$, str2$, strID$

Set db = session.Currentdatabase
Set nnc = db.Createnotecollection(False)
nnc.Selectpages = True
nnc.Selectionformula = {@Begins($TITLE; "StringDiffSample")}
nnc.Buildcollection
If nnc.Count <> 2 Then
MsgBox "Failed to find exactly two pages whose names begin with StringDiffSample"
Exit sub
End If
strID = nnc.Getfirstnoteid
Set docPage = db.Getdocumentbyid(strID)
Set rti = docPage.Getfirstitem("$Body")
str1 = rti.Getunformattedtext
strID = nnc.Getnextnoteid(strID)
Set docPage = db.Getdocumentbyid(strID)
Set rti = docPage.Getfirstitem("$Body")
str2 = rti.Getunformattedtext

Dim strdif As New StringDiffer
Dim diffs As DiffResult
Set diffs = strdif.FindDifferences(Str1, Str2)
If diffs.Same Then
MsgBox "strings are the same"
Else
Dim strFilepath$
strFilepath = GetNotesTempDirectory & "/stringdiffSample.htm"

Dim stream As NotesStream
Set stream = session.Createstream
stream.Open strFilepath, "UTF-8"
stream.Truncate
stream.Writetext "<html><head></head><body>"
Dim dw As New DiffWriterSideBySide(stream)
dw.WriteDiffs diffs
stream.Writetext "</body></html>"
stream.Close
Dim wksp As New NotesUIWorkspace
wksp.Urlopen "file:///" + Replace(strFilepath, "\", "/")
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Agent StringDiff\4. Moved Block Detection
Created Aug 18, 2009 by Andre Guirard/Cambridge/IBM
Description: Demonstrate the Moved Block Detection feature of StringDiffMB
by highlighting differences in the before and after versions of some text.
%END REM
Option Public
Option Declare
Use "StringDiffMB"
Use "TempFolderManager"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim db As NotesDatabase
Dim nnc As NotesNoteCollection
Dim docPage As NotesDocument
Dim rti As NotesRichTextItem
Dim strAll$, str1$, str2$, strID$

Set db = session.Currentdatabase
Set nnc = db.Createnotecollection(False)
nnc.Selectpages = True
nnc.Selectionformula = {$TITLE = "StringDiffMovedBlockSample"}
nnc.Buildcollection
If nnc.Count <> 1 Then
MsgBox "Failed to find exactly one pages called 'StringDiffMovedBlockSample'"
Exit Sub
End If
strID = nnc.Getfirstnoteid
Set docPage = db.Getdocumentbyid(strID)
Set rti = docPage.Getfirstitem("$Body")
strAll = rti.Getunformattedtext
strID = nnc.Getnextnoteid(strID)
str1 = StrRight(StrLeft(strAll, "</original>"), "<original>")
str2 = StrRight(StrLeft(strAll, "</edited>"), "<edited>")

Dim strdif As New StringDiffer(20)
Dim diffs As DiffResult
Set diffs = strdif.FindDifferences(Str1, Str2)
If diffs.Same Then
MsgBox "strings are the same"
Else
Dim strFilepath$
strFilepath = GetNotesTempDirectory & "/stringdiffSample.htm"

Dim stream As NotesStream
Set stream = session.Createstream
stream.Open strFilepath, "UTF-8"
stream.Truncate
stream.Writetext "<html><head></head><body>"
Dim dw As New DiffWriterSideBySide(stream)
dw.WriteDiffs diffs
stream.Writetext "</body></html>"
stream.Close
Dim wksp As New NotesUIWorkspace
wksp.Urlopen "file:///" + Replace(strFilepath, "\", "/")
End If
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Agent TempFolderManager\1. Create a few temporary files
Created Aug 21, 2009 by Andre Guirard/Cambridge/IBM
Description: Sample showing how to use the TempFolderManager class
%END REM
Option Public
Option Declare
Use "TempFolderManager"



'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const WINDOWTITLE = {TempFolderManager Demo}

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim notesTmp$, ans, fname$

notesTmp = GetNotesTempDirectory
ans = InputBox("Here's the Notes temp directory, so you can follow along in a file explorer window.", WINDOWTITLE, notesTmp)

MsgBox "I'll create a new temporary folder now.", 0, WINDOWTITLE
Dim tfm As New TempFolderManager("")

MsgBox "The name of the temporary folder is " & Strtoken(tfm.Path, "/", -1) & {

Now I'll ask for a new temp filename.}, 0, WINDOWTITLE

fname = tfm.CreateFilename("txt", true)

MsgBox "The path of the temporary file is " & fname & {

The file doesn't exist yet; I just asked for a new name. Now I'll create the file (go check).}, 0, WINDOWTITLE

Dim stream As NotesStream
Dim bytes(2) As Byte
bytes(0) = &hEF
bytes(1) = &hBB
bytes(2) = &hBF
Set stream = session.Createstream
stream.Open fname, "UTF-8"
stream.Write bytes
stream.Writetext "世界の地図"
stream.Close

MsgBox {I wrote some text to the file } & fname & {

Just for fun, it's in Japanese, with a 'byte order mark' flagging it as UTF-8.

Next, the script will end. When the TempFolderManager object falls out of scope, the file and folder will be deleted.}, 0, WINDOWTITLE

End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Agent TempFolderManager\2. Leave behind some files
Created Aug 21, 2009 by Andre Guirard/Cambridge/IBM
Description: Sample showing how to use the TempFolderManager class, where some
files are deliberately left behind when the TFM is deallocated.
%END REM
Option Public
Option Declare
Use "TempFolderManager"
Use "AttachmentAdder"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const WINDOWTITLE = {TempFolderManager Demo}

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim notesTmp$, ans, fname$

notesTmp = GetNotesTempDirectory
ans = InputBox("Here's the Notes temp directory, so you can follow along in a file explorer window.", WINDOWTITLE, notesTmp)

Dim tfm As New TempFolderManager("")

MsgBox "The name of the new temporary folder is " & Strtoken(tfm.Path, "/", -1) & {

Now I'll create a few empty subfolders and a gif file in folder3.}, 0, WINDOWTITLE

Dim i%
For i = 1 To 4
MkDir tfm.Path & "/folder" & i
Next

fname = tfm.Path & "/folder3/something.gif"

' fetch the graphic out of a file resource.
Dim circleR As New Image
circleR.LoadImageResource session.Currentdatabase, "lsGold.gif"

' write that to a file
Dim stream As NotesStream
Set stream = session.Createstream
stream.Open fname
circleR.WriteStream stream
stream.Close

MsgBox {Now the script ends, but the temp folder contains files that aren't under manangement, so it won't be deleted.}, 0, WINDOWTITLE
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Agent TempFolderManager\3. Clean up the old files
Created Aug 21, 2009 by Andre Guirard/Cambridge/IBM
Description: Sample showing how to use the TempFolderManager class to clear away
files left by a previous run.
%END REM
Option Public
Option Declare
Use "TempFolderManager"



'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub Initialize()

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const WINDOWTITLE = {TempFolderManager Demo}

'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize()
Dim session As New NotesSession
Dim notesTmp$, ans, fname$

notesTmp = GetNotesTempDirectory
ans = InputBox("Here's the Notes temp directory, so you can follow along in a file explorer window.", WINDOWTITLE, notesTmp)

MsgBox "I'll create a new temporary folder now.", 0, WINDOWTITLE
Dim tfm As New TempFolderManager("")

MsgBox "The name of the temporary folder is " & Strtoken(tfm.Path, "/", -1) & {

Now I'll clean up old temp folders that are older than 15 seconds (if you run these sample agents in order, there should be one).

NOTE: normally your timeout would be more on the order of a couple of days: 15sec is just for demonstration.}, 0, WINDOWTITLE

Dim fifteenSec As Double
fifteenSec = 15.0 / (24. * 60. * 60.)
tfm.CleanupOldFolders(fifteenSec)

MsgBox "I'll create a managed 'txt' file in the temp folder.", 0, WINDOWTITLE
Dim i%, fn%
fname = tfm.CreateFilename("txt", true)
fn = FreeFile
Open fname For Output As fn
Print #fn, "managed content"
Close fn

MsgBox "I'll create some 'dat' files in the temp folder, but only put one under management.", 0, WINDOWTITLE

For i = 1 To 4
fname = tfm.CreateFilename("dat", false)
fn = FreeFile
Open fname For Output As fn
Print #fn, "trash"
Close fn
If i = 4 Then
tfm.Manage fname
End If
Next

MkDir tfm.Path & "/stuff"
fname = tfm.Path & "/stuff/haha.html"
fn = FreeFile
Open fname For Output As fn
Print #fn, "<html><head></head><body>haha</body></html>"
Close fn

MsgBox {Now I'll clean up the two managed files, whose names I've forgotten (one dat file and one txt file).}, 0, WINDOWTITLE
tfm.ClearFiles

MsgBox "Now I'll clean up the other files and folders in the temp folder, but leave the folder behind.", 0, WINDOWTITLE
tfm.ClearAllFiles

MsgBox {Next, the script ends. When the TempFolderManager object falls out of scope, the folder will be deleted.

Folder name = '} & tfm.path & {'}, 0, WINDOWTITLE

End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library 'AttachmentAdder' v 1.0
Created Aug 6, 2009 by Andre Guirard/Cambridge/IBM
Description: Supports the creation of file attachments with custom icons in-memory,
without access to the file system. This is useful for most server agents, which
generally aren't allowed file system access, and for any case where you'd like to
create an attachment with a specific graphic as the attachment icon.
%END REM
Option Public
Option Declare


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class AttachmentAdder
Declare Class Image
Declare Function ReplaceText(rtiNode As NotesDOMElementNode, toReplace$, withWhat As NotesDOMNode, domd As NotesDOMDocumentNode) As Boolean
Declare Function getChildNamed(target$, dome As NotesDOMElementNode) As NotesDOMElementNode
Declare Function TextStreamToBase64(streamIn As NotesStream, ByVal strCharset$) As String
Declare Function TextToBase64(strDat$, ByVal strCharset$) As String
Declare Function StreamToBase64(streamIn As NotesStream) As String
Declare Sub Base64ToBinary(strBase64$, streamOut As NotesStream)

'++LotusScript Development Environment:2:5:(Declarations):0:10
Const ERR_SEARCH_NOTFOUND = &hb07 ' image resource wasn't found.
Const ERR_NO_ICON = &h4C30 ' didn't choose an icon before inserting an image.



%REM
Class AttachmentAdder
Description: Given a Notes document, add one or more attachments to its rich text fields
without accessing the file system.
%END REM
Class AttachmentAdder
m_domp As NotesDOMParser ' parsed DXL of Notes document
m_domd As NotesDOMDocumentNode
m_elDoc As NotesDOMElementNode ' element representing "the design element", normally "note".
m_session As NotesSession
m_items List As NotesDOMElementNode ' list of 'item' elements found in the note.
m_when As NotesDOMElementNode ' <datetime>now</datetime>
m_db As NotesDatabase

Public Icon As Image ' Notice if you're doing a bunch of attachments and have different icons,
' you can keep a collection of Image objects and assign the appropriate one
' for the attachment. That's more efficient than reloading them each time.
Public Log As String ' if something went wrong on Save, find out what here.

%REM
Sub New
Description: Pass in the document to which you want to add an attachment (it need not have
been saved) and bRaw=true to use raw format for existing rich text items (this option
doesn't let you put the attachment in an _existing_ rich text item).
Note: The NotesDocument object is recycled to prevent you creating a conflict by saving
it in the calling code. Use the Save method of this class instead.
%END REM
Sub New(doc As NotesDocument, ByVal bRaw As Boolean)
Dim dxle As NotesDXLExporter
doc.Replaceitemvalue "__AA_When", Now ' an easy way to get the DXL of the current date/time.
Set m_session = New NotesSession
Set m_db = doc.Parentdatabase
Set dxle = m_session.Createdxlexporter(doc)
If bRaw Then
dxle.Forcenoteformat = True
dxle.Richtextoption = RICHTEXTOPTION_RAW
End If
Set m_domp = m_session.Createdomparser(dxle)
dxle.Process
Set m_domd = m_domp.Document
Set m_elDoc = m_domd.Documentelement ' <document> element
Delete doc ' steal the object from the caller.
Dim items As NotesDOMNodeList
Set items = m_domd.Getelementsbytagname("item")
Dim i%, el As NotesDOMElementNode, srNam$
For i = 1 To items.Numberofentries
Set el = items.Getitem(i)
srNam = el.Getattribute("name")
If srNam = "__AA_When" Then
Set m_when = getChildNamed("datetime", el)
el.Parentnode.Removechild el
Else
Set m_items(LCase(srNam)) = el
End If
Next
End Sub

%REM
Sub AddDocAttachBase64
Description: Add the $FILE item containing attachment data to the document.
This creates a V2 style attachment.
%END REM
Sub AddDocAttachBase64(strBase64$, ByVal fileName$)
%REM
Generate the following, where "..." is replaced by the above arguments:
<item Name='$FILE' summary='true' sign='true' seal='true'>
<object>
<file hosttype='msdos' compression='none' flags='storedindoc' encoding='none' name='...'>
<created><datetime dst='true'>20070621T145055,70-05</datetime></created>
<modified><datetime dst='true'>20070621T145055,71-05</datetime></modified>
<filedata>...
%END REM
Dim domeFile As NotesDOMElementNode, domeObj As NotesDOMElementNode, domeFD As NotesDOMElementNode
Dim domeTmp As NotesDOMElementNode, domeItem As NotesDOMElementNode, domeDT As NotesDOMElementNode

Set domeItem = CreateChild("item name=$FILE, summary=true, sign=true, seal=true", m_elDoc)
Set domeObj = CreateChild("object", domeItem)
Set domeFile = CreateChild("file hosttype=msdos, compression=none, flags=storedindoc, encoding=none", domeObj)
domeFile.Setattribute "name", fileName
Set domeTmp = CreateChild("created", domeFile)
domeTmp.Appendchild m_when.Clone(True)
Set domeTmp = CreateChild("modified", domeFile)
domeTmp.Appendchild m_when.Clone(True)
Set domeFD = CreateChild("filedata", domeFile)
domeFD.Appendchild m_domd.Createtextnode(strBase64)
End Sub

%REM
Sub AddDocAttachStream
Description: Binary file attachment with the exact bytes in the stream.
%END REM
Sub AddDocAttachStream(stream As NotesStream, ByVal fileName$)
AddDocAttachBase64 StreamToBase64(stream), fileName
End Sub

%REM
Sub AddDocAttachTextStream
Description: Create v2 style text file attachment. The stream is interpreted as characters in whatever
character set is associated with it, and converted to the character set specified by strCharSet.
%END REM
Sub AddDocAttachTextStream(stream As NotesStream, ByVal strCharset$, ByVal filename)
AddDocAttachBase64 TextStreamToBase64(stream, strCharset), fileName
End Sub

%REM
Function CreateChild
Description: Shortcut way to create a child DOM element with given attributes.
Returns the new node. desc is of the form 'name arg1=x, arg2=y, ...'
No, this doesn't support attributes containing comma or =. Sorry.
%END REM
Private Function CreateChild(desc$, parent As NotesDOMElementNode) As NotesDOMElementNode
Dim nodeName$, args, tmp As NotesDOMElementNode
nodeName = StrToken(desc, " ", 1)
args = FullTrim(Split(StrRight(desc, " "), ","))
Set tmp = m_domd.Createelementnode(nodeName)
If Len(args(0)) Then
ForAll arg In args
tmp.Setattribute StrLeft(arg, "="), StrRight(arg, "=")
End ForAll
End If
parent.Appendchild tmp
Set CreateChild = tmp
End Function

%REM
Sub LoadIcon
Description: Locate an image resource and make it the icon for file attachments.
%END REM
Function LoadIcon(db As NotesDatabase, ByVal imageName$) As Image
Set LoadIcon = New Image
LoadIcon.LoadImageResource db, imageName
Set Icon = LoadIcon
End Function

%REM
Function getRTItem
Description: Return the DOM tree node corresponding to a given rich text item.
If it doesn't exist, item is created.
%END REM
Function getRTItem(itemName$) As NotesDOMElementNode
Dim key$, elRT As NotesDOMElementNode, elItem As NotesDOMElementNode
key = LCase(itemName)
If IsElement(m_items(key)) Then
Set elItem = m_items(key)
Set elRT = getChildNamed("richtext", elItem)
If Not (elRT Is Nothing) Then Set getRTItem = elItem
Else
' doesn't exist, create it.
Dim elPar As NotesDOMElementNode
Set elItem = CreateChild("item", m_elDoc)
elItem.setAttribute "name", itemName
Set m_items(key) = elItem
Set elRT = CreateChild("richtext", elItem)
CreateChild "pardef id=1", elRT
Set elPar = CreateChild("par ref=1", elRT)
End If
Set getRTItem = elItem
End Function

%REM
Function getLastPar
Description: elItem is the <item> element. Find the last <par> within it.
If there's no paragraph, create one.
%END REM
Function getLastPar(elItem As NotesDOMElementNode) As NotesDOMElementNode
Dim elRT As NotesDOMElementNode, elPar As NotesDOMElementNode
Dim elPardef As NotesDOMElementNode, refID$
Dim domnl As NotesDOMNodeList
Set elRT = getChildNamed("richtext", elItem)
Set domnl = elRT.Getelementsbytagname("par")
If domnl.Numberofentries = 0 Then
Set domnl = elRT.Getelementsbytagname("pardef")
If domnl.Numberofentries = 0 Then
Set elPardef = CreateChild("pardef id=1", elRT)
refID = "1"
Else
Set elPardef = domnl.Getitem(domnl.Numberofentries)
refID = elPardef.Getattribute("id")
End If
Set elPar = CreateChild("par", elRT)
elPar.Setattribute "def", refID
Else
Set elPar = domnl.Getitem(domnl.Numberofentries)
End If
Set getLastPar = elPar
End Function

%REM
Sub AppendRTAttach
Description: Add an arrachment reference to the end of a specified rich text item
filename: name of attachment object (must match one attached to the document)
displayName: name to display under the attachment icon.
itemName: which rich text item to attach it to.
%END REM
Sub AppendRTAttach(ByVal filename$, ByVal displayName$, ByVal itemName$)
Dim elItem As NotesDOMElementNode
Dim elPar As NotesDOMElementNode
Set elItem = getRTItem(itemName)
Set elPar = getLastPar(elItem)

elPar.Appendchild CreateAttachRef(filename, displayName)
End Sub


%REM
Function CreateAttachRef
Description: Create the DOM node for an attachment reference to appear as part of
rich text. This can be inserted as a child of a <run> or <par> element.
%END REM
Function CreateAttachRef(ByVal filename$, ByVal displayName$) As NotesDOMElementNode
If icon Is Nothing Then
Error ERR_NO_ICON, "You must define an icon image before attaching to a rich text field."
End If

Dim elAtt As NotesDOMElementNode
Dim elPic As NotesDOMElementNode

Set elAtt = m_domd.Createelementnode("attachmentref")
Set CreateAttachRef = elAtt
elAtt.Setattribute "name", filename
elAtt.Setattribute "displayname", displayName
Set elPic = Icon.CreatePictureElement(m_domd)
elAtt.Appendchild elPic
CreateChild("caption", elPic).Appendchild m_domd.createTextNode(" " & displayName & " ")
End Function

%REM
Sub Save
Description: returns noteID of imported note, "" if there was a problem, in which case check Log property.
%END REM
Function Save As String
On Error GoTo oops
Dim dxli As NotesDXLImporter
Dim stream As NotesStream
Set stream = m_session.Createstream
' m_domp.Serialize
m_domp.Setoutput stream
m_domp.Serialize
' stream.Open "c:\kill\tmp.xml", "UTF-16"
' stream.Truncate
' m_domp.Serialize
Set dxli = m_session.Createdxlimporter(stream, m_db)
dxli.Documentimportoption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
dxli.Inputvalidationoption = VALIDATE_NEVER
dxli.Exitonfirstfatalerror = False
dxli.process
If dxli.Importednotecount Then
Save = dxli.Getfirstimportednoteid
Else
me.Log = dxli.Log
End If
Exit Function
oops:
me.Log = "Error " & Err & ": " & Error & " //AttachmentAdder.Save:" & (GetThreadInfo(0)-Erl) & {
Imported } & dxli.Importednotecount & { notes
} & dxli.log
Exit function
End Function

%REM
Property Get DOMDoc
Description: The "docume
%END REM
Public Property Get DOMDoc As NotesDOMDocumentNode
Set DOMDoc = m_domd
End Property
End Class


%REM
Class Image
Description: Represents an image
%END REM
Class Image
m_base64 As String
m_type As String ' gif or jpeg
m_height As Long
m_width As Long
m_stream As NotesStream
m_imageRef As String ' name of image resource, if any.

Public PreserveRef As Boolean ' if true, when we create a <picture> element we add an imageref rather than the image data.
Public Scale As Double ' scaling factor for X and Y when we generate the <picture> element.
' The scaling is only on display; the image is stored in its original dimensions.

%REM
Sub SetBase64
Description: Replace the image data with base64-encoded data. strType should be "gif" or "jpeg".
%END REM
Sub SetBase64(ByVal strType$, strDat$)
m_type = strType
m_base64 = strDat
Set m_stream = NOTHING
CalculateImageSize
End Sub

%REM
Sub setStream
Description: Set the image contents from a binary stream. Specify strType = gif or jpeg,
streamIn containing the data, bCopy=true if the object should keep a copy of the data
instead of the original stream.
%END REM
Sub setStream(ByVal strType$, streamIn As NotesStream, bCopy As Boolean)
m_type = strType
Set m_stream = streamIn
m_base64 = ""
If bCopy Then
Dim session As New NotesSession
Dim streamTmp As NotesStream
WriteStream streamTmp
Set m_stream = streamTmp
End If
CalculateImageSize
End Sub

%REM
Property Get Height
Description: Number of pixels height in original image (before scaling).
%END REM
Public Property Get Height As Long
height = m_height
End Property

%REM
Property Get Width
Description: Number of pixels width in original image (before scaling).
%END REM
Public Property Get Width As Long
me.Width = m_width
End Property

Private Sub CalculateImageSize
' Calculate dimensions of the image data.
Dim bytArr
Dim w As Integer ' width of image
Dim h As Integer ' height of image
Dim foundMarker As Integer
Dim lngOldPos As Long
Dim session As New NotesSession
Dim st As NotesStream
Set st = Stream

tryAgain:
st.Position = 0
m_Height = 0
m_Width = 0

If m_type = "gif" Then
bytArr = st.Read(16)
' The gif file starts with "GIF89a" followed by width (2 bytes, lo byte first) and height.
' GIF's height and width stored in a fixed location
If bytArr(0) = 255 And bytArr(1) = 216 Then
' fooled ya! It's really a jpeg!
m_type = "jpeg"
GoTo tryAgain
End If
w = CLng(bytArr(7)) * 256& + CLng(bytArr(6))
h = CLng(bytArr(9)) * 256& + CLng(bytArr(8))
Else ' assume "jpeg"
' JPG's dimensions stored in a variable location. The code has been verified with JFIF
' file format (the most common format)
bytArr = st.Read(2)
If Not (bytArr(0) = 255 And bytArr(1) = 216) Then ' Must start with hex FF D8
If bytArr(0) = &h47 And bytArr(1) = &h49 Then ' looks like it's a GIF
m_type = "gif"
GoTo tryAgain
End If
Else
m_type = "jpeg"
foundMarker = False ' Look for the marker that will contain the height and width
While Not foundMarker
bytArr = st.Read(2) ' Grab the next marker
' Look for the marker (in hex) FF C0, FF C1, FF C2, or FF C3
If bytArr(0) = 255 And bytArr(1) >= 192 And bytArr(1) <= 195 Then
bytArr = st.Read(7)
' consisting of the marker length (2 bytes), an ignorable byte,
' the image height (2 bytes hi first), and width.
h = CLng(bytArr(3)) * 256& + CLng(bytArr(4))
w = CLng(bytArr(5)) * 256& + CLng(bytArr(6))
foundMarker = True ' Exit the while loop
Else ' It's not one of the special markers - skip over it
bytArr = st.Read(2) ' Next two bytes are the marker length
st.Position = st.Position + bytArr(0)*256& + bytArr(1) - 2&
' Skip over that many bytes (minus the 2 byte length already read)
End If
Wend ' Continue until the marker is found
End If ' Ends the check to see if the file starts with FF D8
End If ' Ends the check to see if the format is GIF or JPG
AfterError:
m_Width = w
m_Height = h
End Sub

%REM
Sub LoadImageResource
Description: resName is the name of an image resource in db. Case sensitive, but
you can use name or alias.
%END REM
Sub LoadImageResource(db As NotesDatabase, ByVal resName$)
On Error GoTo oops
Dim nnc As NotesNoteCollection
Set nnc = db.Createnotecollection(False)
nnc.Selectimageresources = True
nnc.Selectionformula = {$TITLE = "} & resName & {"}
nnc.Buildcollection
Dim dxle As NotesDXLExporter
Dim doc As NotesDocument
Dim session As New NotesSession, tmp
Set doc = db.Getdocumentbyid(nnc.Getfirstnoteid)
tmp = doc.Getitemvalue("$TITLE")
m_imageRef = tmp(UBound(tmp))
Set dxle = session.Createdxlexporter(doc)
Dim domp As NotesDOMParser
Set domp = session.Createdomparser(dxle)
dxle.Process
Dim domd As NotesDOMDocumentNode
Dim elDElem As NotesDOMElementNode
Set domd = domp.Document
Set elDElem = domd.Getelementsbytagname("imageresource").Getitem(1)
Dim elTmp As NotesDOMNode
Set elTmp = elDElem.Firstchild
Do Until elTmp.Isnull
If elTmp.Nodename = "gif" Or elTmp.Nodename = "jpeg" Then
SetBase64 elTmp.Nodename, elTmp.Firstchild.Nodevalue ' base64 contents
Exit Sub
End If
Set elTmp = elTmp.Nextsibling
Loop
oops:
Error ERR_SEARCH_NOTFOUND, "Image resource not found: '" & resName & "'"
Exit Sub
End Sub

%REM
Sub PopulateBase64
Description: In case the image contents have been set via a stream, the
m_base64 will be blank. In that case, derive it from the stream.
%END REM
Private Sub PopulateBase64
If Len(m_base64) = 0 And Not (m_stream Is Nothing) Then
m_base64 = StreamToBase64(m_stream)
End If
End Sub

%REM
Property Get Base64
Description: Return the base-64 encoded version of the image data.
%END REM
Public Property Get Base64 As String
PopulateBase64
base64 = m_base64
End Property

%REM
Property Get Stream
Description: Return the binary image data As a NotesStream.
%END REM
Public Property Get Stream As NotesStream
If m_stream Is Nothing Then
Dim session As New NotesSession
Set m_stream = session.createstream
base64ToBinary m_base64, m_stream
End If
Set stream = m_stream
End Property

%REM
Sub WriteStream
Description: Write the image contents to a stream (you can also just get the stream
with the Stream property, which is faster, but you can't attach that to a file
to write the file, because the data are already in it).
%END REM
Sub WriteStream(streamOut As NotesStream)
Dim streamCur As NotesStream
Set streamCur = Stream
streamCur.Position = 0
Do Until streamCur.Position >= streamCur.Bytes
streamOut.Write streamCur.Read(16000)
Loop
End Sub

%REM
Function CreateContentElement
Description: Create DOM node <gif>(base64 text node)</gif> (or jpeg) containing the
base-64 encoded image data.
%END REM
Function CreateContentElement(domd As NotesDOMDocumentNode) As NotesDOMElementNode
Dim elGraf As NotesDOMElementNode
Set elGraf = domd.Createelementnode(m_type)
PopulateBase64
elGraf.Appendchild domd.createtextnode(m_base64)
Set CreateContentElement = elGraf
End Function

%REM
Function CreatePictureElement
Description: Create a <picture> element with the height, width, and contents.
This can be inserted as a child of a <run> or <par> element of rich text
(and a few other places) to make the picture appear there.
If bRef is true, we create an "imageref" element if the data came from an image resource.
Note this would make the image not come through if the document were mailed or copied
to another database, but it does save a little space.
%END REM
Function CreatePictureElement(domd As NotesDOMDocumentNode) As NotesDOMElementNode
Set CreatePictureElement = domd.Createelementnode("picture")
If m_height Then
CreatePictureElement.Setattribute "height", CStr(CLng(m_Height * Scale))
CreatePictureElement.Setattribute "width", CStr(CLng(m_width * Scale))
End If
Dim elPic As NotesDOMElementNode

If PreserveRef And Len(m_imageRef) Then
Set elPic = domd.Createelementnode("imageref")
elPic.SetAttribute "name", m_imageRef
Else
Set elPic = CreateContentElement(domd)
End If
CreatePictureElement.AppendChild elPic
End Function

Sub New
Scale = 1
End Sub
End Class
'++LotusScript Development Environment:2:1:ReplaceText:6:8
%REM
Function ReplaceText
Description: Given a parent DOM node which is part of some rich text, search its tree for
a text node containing a given string. Replace this string with a given DOM element.
%END REM
Function ReplaceText(rtiNode As NotesDOMElementNode, toReplace$, withWhat As NotesDOMNode, domd As NotesDOMDocumentNode) As Boolean
Dim child As NotesDOMNode, pos As Long
Set child = rtiNode.Firstchild
Do Until child.isnull Or ReplaceText
Select Case child.Nodetype
Case DOMNODETYPE_ELEMENT_NODE
ReplaceText = ReplaceText(child, toReplace, withWhat, domd)
Case DOMNODETYPE_TEXT_NODE
If rtiNode.Nodename = "run" Or rtiNode.Nodename = "par" Then
pos = InStr(child.Nodevalue, toReplace)
If pos Then
Dim strBefore$, strAfter$
Dim frag As NotesDOMDocumentFragmentNode
strBefore = Left(child.Nodevalue, pos-1)
strAfter = Mid$(child.Nodevalue, pos+Len(toReplace))
If Not child.Nextsibling.Isnull then
' remove all following nodes temporarily
Dim nextNode As NotesDOMNode
Set frag = domd.Createdocumentfragmentnode
Set nextNode = child.Nextsibling
Do Until nextNode.Isnull
frag.Appendchild nextNode
Set nextNode = child.Nextsibling
Loop
End if
If Len(strBefore) Then
child.Nodevalue = strBefore
Else
rtiNode.Removechild child
End If
rtiNode.Appendchild withWhat
If Len(strAfter) Then
rtiNode.Appendchild domd.Createtextnode(strAfter)
End If
If Not (frag Is Nothing) Then
rtiNode.Appendchild frag
End If
ReplaceText = True
Exit Function
End If
End If
End Select
Set child = child.Nextsibling
Loop
End Function












'++LotusScript Development Environment:2:1:getChildNamed:6:8
%REM
Function getChildNamed
Description: given a name and an element, find the first child of that element with the
given tag name.
%END REM
Function getChildNamed(target$, dome As NotesDOMElementNode) As NotesDOMElementNode
Dim domn As NotesDOMNode
Set domn = dome.Firstchild
Do Until domn.Isnull
If domn.Nodetype = DOMNODETYPE_ELEMENT_NODE Then
If domn.Nodename = target Then
Set getChildNamed = domn
Exit Function
End If
End If
Set domn = domn.Nextsibling
Loop
End Function

'++LotusScript Development Environment:2:1:getDocNode:0:8
%REM
Function getDocNode
Description: Find the DOM "document" node from which a given node was derived.
The doc node is needed to create new nodes.
%END REM
'Function getDocNode(node As NotesDOMNode) As NotesDOMDocumentNode
' Dim par As NotesDOMNode
' Set par = node
' Do
' Set par = par.Parentnode
' Loop Until par.Nodetype = DOMNODETYPE_DOCUMENT_NODE
' Set getDocNode = par
'End Function



'++LotusScript Development Environment:2:1:TextStreamToBase64:8:8
%REM
Function TextStreamToBase64
Description: Convert a text NotesStream to a string of Base64 data in a specified
character set. The NotesStream is assumed to have a correct Charset attribute
and we want to convert whatever that is to maybe a different character set,
then base64 encode that.
%END REM
Function TextStreamToBase64(streamIn As NotesStream, ByVal strCharset$) As String
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body")
streamIn.Position = 0
If strCharset = "" Then strCharset = "US-ASCII"
mime.Setcontentfromtext streamIn, "text/plain;charset=" & strCharset, ENC_NONE
mime.EncodeContent(ENC_BASE64)
TextStreamToBase64 = mime.ContentAsText
End Function

'++LotusScript Development Environment:2:1:TextToBase64:6:8
%REM
Function TextToBase64
Description: Convert a Unicode string to a different character set specified by
the strCharset argument, then convert that to base64 representation.
%END REM
Function TextToBase64(strDat$, ByVal strCharset$) As String
' Convert a string to Base64 data in a specified character set.
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body")
Dim stream As NotesStream
Set stream = session.Createstream
stream.Writetext strDat
stream.Position = 0
If strCharset = "" Then strCharset = "US-ASCII"
mime.Setcontentfromtext stream, "text/plain;charset=" & strCharset, ENC_NONE
mime.EncodeContent ENC_BASE64
TextToBase64 = mime.ContentAsText
End Function


'++LotusScript Development Environment:2:1:StreamToBase64:1:8
Function StreamToBase64(streamIn As NotesStream) As String
' Convert a binary NotesStream to a string of Base64 data.
' The output can be used as part of DXL data for importing.
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body")
streamIn.Position = 0
Call mime.SetContentFromBytes(streamIn, "image/gif", ENC_NONE)
mime.EncodeContent(ENC_BASE64)
StreamToBase64 = mime.ContentAsText
End Function


'++LotusScript Development Environment:2:2:Base64ToBinary:7:8
%REM
Sub Base64ToBinary
Description: Given a string of base64-encoded data, write into a binary stream we are passed.
This is done rather than creating the stream here and returning it, so that you can
stream directly into a file if you choose.
%END REM
Sub Base64ToBinary(strBase64$, streamOut As NotesStream)
' Given a string of base64 encoded data, this routine decodes and writes the original binary data into a NotesStream
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity
Dim streamIn As NotesStream
Dim db As NotesDatabase
Dim session As New NotesSession

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body") ' the mime classes already know how to do this conversion,
Set streamIn = session.CreateStream
Call streamIn.WriteText(strBase64)
streamIn.Position = 0
Call mime.SetContentFromText(streamIn, "binary", ENC_BASE64)
Call mime.GetContentAsBytes(streamOut, True) ' decode as you stream out the data.
End Sub










'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library "DebugStrLC" by Andre Guirard/Cambridge/IBM
Description: Originally published in Lotus Sandbox. The DebugStrLC
function returns a text description of a variant value it is passed,
intended to be displayed for debugging purposes. This is a more
comprehensive version of the DebugStr function published elsewhere.
%END REM

Option Public
Option Declare

Uselsx "*lsxlc"

%REM
This library contains two functions used for debugging:

Function DebugStr(vel As Variant, Byval brief As Boolean) As String
Given any value vel, of any type, returns a text description of the value.
If brief=False, for some datatypes, a more detailed description is provided.

Sub DebugPrint(Byval s As String)
Calls the system function Print to output a string; however, if the string
is too long to do in a single Print statement, it splits it up into multiple
Print calls.
%END REM

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Private Function DebugFieldFlags(Byval flags As Long) As String
Declare Private Function debugStrLCField(vel, Byval brief As Boolean) As String
Declare Private Function debugFMTName(ffmt As Long) As String
Declare Private Function debugProperties(x) As String
Declare Private Function debugFieldVirtCodes(vel) As String
Declare Sub DebugPrint(Byval s As String)
Declare Function DebugStrLC(vel As Variant, Byval brief As Boolean) As String

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:1:DebugFieldFlags:1:8
Private Function DebugFieldFlags(Byval flags As Long) As String
Dim strResult As String
If flags And LCFIELDF_KEY Then
strResult = ",key"
flags = flags And (Not LCFIELDF_KEY)
End If
If flags And LCFIELDF_KEY_NE Then
strResult = strResult & ",!="
flags = flags And (Not LCFIELDF_KEY_NE)
End If
If flags And LCFIELDF_KEY_GT Then
strResult = strResult & ",>"
flags = flags And (Not LCFIELDF_KEY_GT)
End If
If flags And LCFIELDF_KEY_LT Then
strResult = strResult & ",<"
flags = flags And (Not LCFIELDF_KEY_LT)
End If
If flags And LCFIELDF_NO_NULL Then
strResult = strResult & ",nonull"
flags = flags And (Not LCFIELDF_NO_NULL)
End If
If flags And LCFIELDF_TRUNC_PREC Then
strResult = strResult & ",truncprec"
flags = flags And (Not LCFIELDF_TRUNC_PREC)
End If
If flags And LCFIELDF_TRUNC_DATA Then
strResult = strResult & ",truncdata"
flags = flags And (Not LCFIELDF_TRUNC_DATA)
End If
If flags And LCFIELDF_NO_FETCH Then
strResult = strResult & ",nofetch"
flags = flags And (Not LCFIELDF_NO_FETCH)
End If
If flags And LCFIELDF_NO_INSERT Then
strResult = strResult & ",noinsert"
flags = flags And (Not LCFIELDF_NO_INSERT)
End If
If flags And LCFIELDF_NO_UPDATE Then
strResult = strResult & ",noupdate"
flags = flags And (Not LCFIELDF_NO_UPDATE)
End If
If flags And LCFIELDF_NO_REMOVE Then
strResult = strResult & ",noremove"
flags = flags And (Not LCFIELDF_NO_REMOVE)
End If
If flags And LCFIELDF_NO_CREATE Then
strResult = strResult & ",nocreate"
flags = flags And (Not LCFIELDF_NO_CREATE)
End If
If flags And LCFIELDF_NO_DROP Then
strResult = strResult & ",nodrop"
flags = flags And (Not LCFIELDF_NO_DROP)
End If
If flags > 0 Then
strResult = strResult & flags & "?"
End If
If strResult <> "" Then DebugFieldFlags = "[" & Mid$(strResult, 2) & "]"
End Function

'++LotusScript Development Environment:2:1:debugStrLCField:2:8

Private Function debugStrLCField(vel, Byval brief As Boolean) As String
Dim buf As LCStream
Dim ffmt As Long, fmax As Long, fflg As Long
If brief Then
If vel.IsNull(1) Then
debugStrLCField = "NULL"
Elseif vel.Datatype = LCTYPE_BINARY Then
Call vel.GetFormatStream(fflg, fmax, ffmt)
Set buf = vel.GetStream(1, ffmt)
Select Case ffmt
Case LCSTREAMFMT_TEXT_LIST, LCSTREAMFMT_NUMBER_LIST, LCSTREAMFMT_DATETIME_LIST
debugStrLCField = "(" & debugstrLC(buf.value, True) & ")"
Case Else
debugStrLCField = "(binary)"
End Select
Else
debugStrLCField = debugStrLC(vel.Value, brief)
End If
Else
If vel.Datatype = LCTYPE_BINARY Then
Call vel.GetFormatStream(fflg, fmax, ffmt)
Set buf = vel.GetStream(1, ffmt)
If ffmt = LCSTREAMFMT_TEXT_LIST Then
debugStrLCField = "F(textlist:" & buf.Text & ")"
Elseif ffmt = LCSTREAMFMT_NUMBER_LIST Then
debugStrLCField = "F(numlist:" & buf.Text & ")"
Elseif ffmt = LCSTREAMFMT_DATETIME_LIST Then
debugStrLCField = "F(datelist:" & buf.Text & ")"
Else
debugStrLCField = "F(binary:" & debugFMTName(ffmt) & ", " & buf.Length & " bytes)"
End If
Else
debugStrLCField = "F" & debugStrLC(vel.Value, brief)
End If
debugStrLCField = debugStrLCField & DebugFieldFlags(vel.Flags) & DebugFieldVirtCodes(vel)
End If
End Function

'++LotusScript Development Environment:2:1:debugFMTName:1:8
Private Function debugFMTName(ffmt As Long) As String
Select Case ffmt
Case LCSTREAMFMT_BLOB
debugFMTName = "BLOB"
Case LCSTREAMFMT_COMPOSITE
debugFMTName = "COMPOSITE"
Case LCSTREAMFMT_TEXT_LIST
debugFMTName = "TEXTLIST"
Case LCSTREAMFMT_NUMBER_LIST
debugFMTName = "NUMBERLIST"
Case LCSTREAMFMT_DATETIME_LIST
debugFMTName = "DATETIMELIST"
Case Else
debugFMTName = "format=" & ffmt & "?"
End Select
End Function

'++LotusScript Development Environment:2:1:debugProperties:1:8
Private Function debugProperties(x) As String
' create a string listing all properties of a LCConnection or LCSession
Dim lngTok As Long, lngTyp As Long, lngFlg As Long, strNam As String, more As Boolean, strResult As String
Dim fProp As LCField
more = x.ListProperty(LCLIST_FIRST, lngTok, lngTyp, lngFlg, strNam)
While more
On Error Goto invalidProperty
Set fProp = x.GetProperty(lngTok)
strResult = strResult & ", " & strNam & "=" & debugstrLC(fProp, True)
nextProperty:
more = x.ListProperty(LCLIST_NEXT, lngTok, lngTyp, lngFlg, strNam)
Wend
debugProperties = Mid$(strResult, 3)
Exit Function
invalidProperty:
Resume nextProperty
End Function

'++LotusScript Development Environment:2:1:debugFieldVirtCodes:1:8
Private Function debugFieldVirtCodes(vel) As String
Dim lngVcode As Long
If vel.ListVirtualCode(LCLIST_FIRST, lngVcode) Then
debugFieldVirtCodes = debugFieldVirtCodes & "," & lngVcode
End If
If debugFieldVirtCodes <> "" Then debugFieldVirtCodes = "[virtcodes=" & Mid$(debugFieldVirtCodes, 2) & "]"
End Function

'++LotusScript Development Environment:2:2:DebugPrint:1:8
Sub DebugPrint(Byval s As String)
Dim pos As Long
While Len(s) > 200
pos = Instr(180, s, " ")
If pos = 0 Then
Print s
Exit Sub
Else
Print Left$(s, pos-1)
s = Mid$(s, pos+1)
End If
Wend
If Len(s) > 0 Then
Print s
End If
End Sub

'++LotusScript Development Environment:2:1:DebugStrLC:1:8
Function DebugStrLC(vel As Variant, Byval brief As Boolean) As String
' This function takes any variant or object and returns a string describing its value.
' E.g. a string type is converted to a string enclosed in quotes, a date or number is
' simply converted to its default string representation, and there are special notations
' for arrays and lists. For any object, the type name of the object is shown.
On Error Goto oops

Dim result$, cc$
Dim i%
If Isarray(vel) Then
Forall values In vel
result$ = result$ & ", " & DebugStrLC(values, brief)
End Forall
DebugStrLC= "(" + Mid$(result$, 3) + ")"
Elseif Islist(vel) Then
Forall lvalues In vel
result$ = result$ + ", " + Listtag(lvalues) + "|" + DebugStrLC(lvalues, brief)
End Forall
DebugStrLC= "{" + Mid$(result$, 3) + "}"
Else
If Isobject(vel) Then
If vel Is Nothing Then
DebugStrLC = Typename(vel) & ":NOTHING"
Exit Function
End If
End If
Select Case Datatype(vel)
Case 0 ' EMPTY
DebugStrLC= "EMPTY"
Case 1 ' NULL
DebugStrLC= "NULL"
Case 2, 3, 4, 5, 6, 7 ' any number or date
DebugStrLC= Cstr(vel)
Case 8 ' String
DebugStrLC= """"
For i% = 1 To Len(vel)
cc$ = Mid$(vel, i%, 1)
Select Case cc$
Case """", "\"
DebugStrLC = DebugStrLC & "\" & cc$
Case "a" To "z", "A" To "Z", "0" To "9"
DebugStrLC = DebugStrLC & cc$
Case Else
If Instr(".,`~/?;:'|{}[]=+-_)(*&^%$# @!", cc$) Then
DebugStrLC = DebugStrLC + cc$
Else
DebugStrLC = DebugStrLC & "\" & Uni(cc$) & "."
End If
End Select
Next
DebugStrLC = DebugStrLC + """"
Case 9 ' OLE object or NOTHING
If vel Is Nothing Then
DebugStrLC= "NOTHING"
Else
DebugStrLC= "OLE Object"
End If
Case 10 ' OLE error
DebugStrLC= "OLE Error"
Case 11 ' Boolean
If vel Then
DebugStrLC= "True"
Else
DebugStrLC= "False"
End If
Case Else
DebugStrLC= Typename(vel)
Select Case Typename(vel)
Case "NOTESDOCUMENT"
DebugStrLC = DebugStrLC & " noteID=" & vel.noteid
Case "NOTESVIEW"
DebugStrLC = DebugStrLC & {(} & vel.name & {)}
Case "NOTESDOCUMENTCOLLECTION"
DebugStrLC = DebugStrLC & {(} & vel.count & {)}
Case "LCFIELDLIST"
result = ""
For i = 1 To vel.FieldCount
result = result & ", " & vel.GetName(i) & "=" & DebugStrLC(vel.GetField(i), brief)
Next
If brief Then
DebugStrLC = Mid$(result, 3)
Else
DebugStrLC = "FL<" & Mid$(result, 3) & ">"
End If
Case "LCFIELD"
DebugStrLC = debugStrLCField(vel, brief)
Case "LCCONNECTION"
DebugStrLC = DebugStrLC & {< } & debugProperties(vel) & { >}
End Select
End Select
End If
Exit Function

oops:
DebugStrLC = "error " & Err & ": " & Error & "//" & Lsi_info(1) & ":" & Erl
Exit Function
End Function
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library 'DECSDatabase'
Description: A class to support the use of DECS or LEI connection documents
to create a connection to a database (relational or otherwise).
%END REM

Option Public
Option Declare
Uselsx "*lsxlc"

%REM
The DECSDatabase class provides tools for working with Connection and Activity documents in a
DECS or LEI Administration database (decsadm.nsf).

The class definition contains comments with specifics.
%END REM

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class DECSDatabase

'++LotusScript Development Environment:2:5:(Declarations):0:10
%INCLUDE "lsxbeerr.lss"
Public Const LCERR_NOMULTIMETA = 3045
Public Const ErrAdtCreateError = 217

' LCTRACE_TO_xxx constants provide names for the flags in the OutputRecord property of the
' trace metaconnection.
Public Const LCTRACE_TO_LOG = 1 ' output to LEI log database (only for scripted activity)
Public Const LCTRACE_TO_FILE = 2 ' output to file (must also assign LogFilename property)
Public Const LCTRACE_TO_CONSOLE = 4 ' output to stdio -- whatever that is in your current context.

Class DECSDatabase
db As NotesDatabase
connectionView As NotesView
activityView As NotesView

' properties:
' connections (NotesView): the view that contains the connection documents sorted by name.
' activities (NotesView): the view that contains DECS/LEI Activity documents sorted by name.
' Database (NotesDatabase): The object representing the DECS Administrator database.

' methods:
' New(server As String, filepath As String)
' The server and filepath give the location of the DECS or LEI Administrator database.
' PropertiesFromDoc(docCon as NotesDocument, lccon as LCConnection):
' Given a DECS/LEI connection document and a connection, initializes the properties of the connection
' from the data in the connection document. The document may be either a regular connection or a metaconnection.
' If a metaconnection, only the metaconnector-specific properties will be assigned, however.
' GetConnectionDoc(Byval conName As String) As NotesDocument
' Given the title of a connection document, this function searches for it in the view and
' returns the first NotesDocument matching that name.
' ConnectionFromDoc(docCon as NotesDocument) As LCConnection
' Given a DECS/LEI connection document, returns a new LCConnection which has been initilaized from the
' data in the connection document. The connection doc may be a metaconnection. Note, however, that the LSX
' supports only one level of metaconnection, so the routine will return an error if passed a metaconnection
' document that refers to another metaconnection.
' GetConnection(name as String) as LCConnection
' Given a connection name, this routine finds the corresponding connection document, creates a new
' LCConnection object, and loads it up with information from the connection document. This routine can
' handle one level of metaconnection, i.e. you may pass the name of a metaconnection document that
' refers to a connection. However, if you pass the name of a metaconnection that refers to another
' metaconnection, you'll get an error because the LSX doesn't support this.
' GetBaseConnection(name as String) As LCConnection
' Like GetConnection, except that it ignores metaconnections and drills down to the connector that the
' metaconnections refer to. E.g. if metaconnection A refers to connection B, then GetBaseConnection("A")
' and GetBaseConnection("B") give the same result.
' Metaconnect(source As Variant, Byval strMetaName As String) As LCConnection
' 'source' is either a string which is the title of a connection document, or an LCConnection object.
' strMetaName is the name of a metaconnector, e.g. "trace". The function creates a new LCConnection
' to the named metaconnector, which has as its base connector the "source" connection.
' MetaconnectOrder(source As Variant, Byval strOrderNames As String) As LCConnection
' Like Metaconnect, 'source' is an LCConnection or name of a connection doc (string).
' Creates an Order metaconnection with 'source' as its base connection, sorted by the fields
' listed in strOrderNames (comma delimited string).
' MetaconnectCollexp(source As Variant, Byval strGroupKeys As String, Byval strWriteKeys As String
' ) As LCConnection
' Like Metaconnect, 'source' is an LCConnection or name of a connection doc (string).
' Creates a collapse/expand metaconnection with 'source' as its base connection.
' strGroupKeys is the comma-delimited list of keys that must be the same to group multiple
' rows into a single row. strWriteKeys is the comma-delimited list of keys that identify a
' particular entry within a group as "the same row" as an entry in the multivalue data.
'
' note: we could add a couple more Meta methods for trace and meter, but these are less often used.

Sub New (server, filepath)
Set db = New NotesDatabase(server, filepath)
If Not db.IsOpen Then
Error lsERR_NOTES_DATABASE_NOTOPEN
End If
End Sub

Private Function NewConnection(Byval strType As String) As LCConnection
' Given a database type strType, e.g. "db2", creates a LCConnection of that type.
retry:
On Error ErrAdtCreateError Goto trap
Set NewConnection = New LCConnection(strType)
Exit Function

trap: ' creating the connection failed. If the connection type is "notesei", try "notes" instead;
' notesei is the new name of the Notes connector, but possibly we are using a version that
' doesn't recognize that name.
If Lcase(strType) = "notesei" Then
strType = "notes"
Resume retry
End If
Error Err, Error & { (opening connector "} & strType & {") // DECSDatabase.NewConnection:} & Erl
End Function

Public Property Get Database( ) As NotesDatabase
Set Database = db
End Property

Public Property Get connections As NotesView
If connectionView Is Nothing Then
Set connectionView = db.GetView("(CS_Connectors)")
If connectionView Is Nothing Then Error lsERR_NOTES_VIEWOPEN_FAILED
End If
Set connections = connectionView
End Property

Public Property Get activities As NotesView
If activityView Is Nothing Then
Set activityView = db.GetView("(CS_Activities)")
If activityView Is Nothing Then Error lsERR_NOTES_VIEWOPEN_FAILED
End If
Set activities = activityView
End Property

Private Function IsMeta(docCon As NotesDocument) As Boolean
' Returns True if a connection document is a metaconnection
IsMeta = (docCon.GetItemValue("ConnectionType")(0) = "Meta")
End Function

Private Sub SetPropertiesFromDoc(docCon As NotesDocument, lccon As LCConnection, _
Byval baseOnly As Boolean)
' Given a NotesDocument (which is expected to be a connection doc)
' and an LCConnection, loads the connection properties from the
' document into the connection. If baseOnly flag is true, the
' connection doc may not be a metaconnection, or an error results.
On Error Goto oops
On Error 12555 Resume Next ' if property doesn't exist, ignore error.
Dim tokens, names
With docCon
tokens = .GetItemValue("PropTokenList")
names = .GetItemValue("PropNameList")
Dim fval As New LCStream
Dim i%
For i = Lbound(tokens) To Ubound(tokens)
If names(i) <> "Library" And names(i) <> "Name" And names(i) <> "Link" Then
fval.Text = .GetItemValue(names(i))(0)
Call lccon.SetPropertyStream(tokens(i), fval)
End If
Next

' now, if this is a metaconnector, load the properties of the base document.
If isMeta(docCon) Then
If baseOnly Then Error LCERR_NOMULTIMETA, {Metaconnection to metaconnector not supported from LotusScript.}
Dim docBase As NotesDocument, key As String
key = docCon.getitemvalue ("Link")(0)
Set docBase = GetConnectionDoc(key)
lccon.ConnectorName = docBase.GetItemValue("Library")(0)
SetPropertiesFromDoc docBase, lccon, True
End If

' If there's an owner and metadata defined, assign those properties.
Dim owner As String
owner = .GetItemValue("OwnerName")(0)
If owner <> "" Then
On Error Resume Next ' if Owner not a valid property, ignore error.
lccon.Owner = owner
On Error Goto 0
End If
Dim meta As String, metaType As String
meta = .GetItemValue("Metadata")(0)
If meta <> "" Then
metaType = .GetItemValue("MetadataType")(0)
' metaType = 2 for a stored procedure, 0 for table, 1 for table or view.
If metaType = "2" Then lccon.Procedure = meta Else lccon.Metadata = meta
End If
End With
Exit Sub
oops:
Error Err, Error & " // " & Getthreadinfo(1) & ":" & Erl
End Sub

Function ConnectionFromDoc(docCon As NotesDocument) As LCConnection
' Given a connection document from the DECS/LEI database, this function
' creates a new LCConnection and assigns its properties based on the
' data in the document.
Dim strLibrary As String
strLibrary = docCon.GetItemValue("Library")(0)
On Error Goto oops
Set ConnectionFromDoc = NewConnection(strLibrary)
SetPropertiesFromDoc docCon, ConnectionFromDoc, False
Exit Function
oops:
Error Err, Error & { (loading LCConnection "} & strLibrary & {") // DECSDatabase.ConnectionFromDoc:} & Erl
End Function

Function GetConnectionDoc(Byval conName As String) As NotesDocument
' given a key string, search the view of connections for a connection doc with that name, and return
' its NotesDocument object.
Set GetConnectionDoc = connections.GetDocumentByKey(conName, True)
If GetConnectionDoc Is Nothing Then Error lsERR_NOTES_DOCSEARCH_FAILED, {Connection document "} & conName & {" not found.}
End Function

Private Function GetBaseConnectionDoc(Byval conName As String) As NotesDocument
' Given a connection document name, find that connection document; if the connection is a
' metaconnection, return the connection document to which it refers.
Set GetBaseConnectionDoc = GetConnectionDoc(conName) ' throws an error if doc not found.
While isMeta(GetBaseConnectionDoc)
Set GetBaseConnectionDoc = GetConnectionDoc(GetBaseConnectionDoc.getitemvalue ("Link")(0))
Wend
End Function

Function GetConnection(Byval conName As String) As LCConnection
' Create an LCConnection based on a connection document; the conName is the
' title of the connection document.
Dim docCon As NotesDocument
Set docCon = GetConnectionDoc(conName) ' throws an error if doc not found.
Set GetConnection = ConnectionFromDoc(docCon)
End Function

Function GetBaseConnection(Byval conName As String) As LCConnection
' This is like GetConnection, except if the named connection is a metaconnection, it
' instantiates the base connection instead -- the connection to which the meta refers.
Dim docCon As NotesDocument
Set docCon = GetBaseConnectionDoc(conName) ' throws an error if doc not found.
Set GetBaseConnection = ConnectionFromDoc(docCon)
End Function

Function Metaconnect(source As Variant, Byval strMetaName As String) As LCConnection
' This function, given either a connection object or a name of
' a connection document, loads up an metaconnection with that
' connection as the back end. Note: this doesn't work if the source
' object is already a metaconnection.
On Error Goto oops
Dim strConnectorName As String
Dim docCon As NotesDocument
If Typename(source) = "LCCONNECTION" Then
Dim lngTok As Long, lngTyp As Long
Dim lngFlg As Long, strNam As String
Dim more As Boolean
Dim fldProp As LCField
Set Metaconnect = New LCConnection(strMetaName)
Metaconnect.ConnectorName = source.ConnectorName
more = source.ListProperty(LCLIST_FIRST, lngTok, lngTyp, lngFlg, strNam)
On Error Goto invalidProperty
While more
If 0 = (lngFlg And LCPROPERTYF_READONLY) And strNam <> "ConnectorName" Then
Set fldProp = source.GetProperty(lngTok)
Call Metaconnect.SetProperty(lngTok, fldProp)
End If
nextProperty:
more = source.ListProperty(LCLIST_NEXT, lngTok, lngTyp, lngFlg, strNam)
Wend
Else
Set docCon = GetConnectionDoc(source)
Set Metaconnect = New LCConnection(strMetaName)
Metaconnect.ConnectorName = docCon.GetItemValue("Library")(0)
Call SetPropertiesFromDoc(docCon, Metaconnect, True)
End If
Exit Function
oops:
Error Err, Error & " // " & Getthreadinfo(1) & ":" & Erl
invalidProperty:
Resume nextProperty
End Function

Function MetaconnectOrder(source As Variant, Byval strOrderNames As String) As LCConnection
Set MetaconnectOrder = Metaconnect(source, "order")
MetaconnectOrder.OrderNames = strOrderNames
End Function

Function MetaconnectCollexp(source As Variant, Byval strGroupKeys As String, Byval strWriteKeys As String _
) As LCConnection
' Create a collapse/expand metaconnection object, based on the other connection or connection
' document name we are passed. Arguments:
' source: an LCConnection which we want to filter thru collapse/expand,
' or a string which is the name of a connection document in the DECS admin.
' strGroupKeys: the names of key fields that, if they are the same, make records get collapsed
' into a single multivalue record.
' strWriteKeys: field names used during update to identify which of multiple rows that have
' the same group key, should be updated when data changes.
Set MetaconnectCollexp = Metaconnect(source, "collexp")
MetaconnectCollexp.GroupKeys = strGroupKeys
MetaconnectCollexp.WriteKeys = strWriteKeys
End Function

End Class
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Library DesignUtils
Created Mar 8, 2010 by Andre Guirard/Cambridge/IBM
Description: Some functions useful in programmatically manipulating design elements.
%END REM
Option Public
Option Declare


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Function Macroquote(ByVal x As String) As String
Declare Sub SetSelectionExt(ncoll As NotesNoteCollection, ByVal strDesignType As String, _
ByVal addlCond$, ByVal flags%)
Declare Sub SetSelection(ncoll As NotesNoteCollection, ByVal strDesignType As String)

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:1:Macroquote:1:8
Function Macroquote(ByVal x As String) As String
' convert string to macro code quoted string; change all " to \" and add quotes at start and end.
Dim fromArr(0 To 0) As String
Dim toArr(0 To 0) As String
Dim targetArr(0 To 0) As String
If InStr(x, {"}) Then
fromArr(0) = {"}
toArr(0) = {\"}
targetArr(0) = x
Dim result As Variant
result = Replace(targetArr, fromArr, toArr)
macroquote = {"} & result(0) & {"}
Else
macroquote = {"} & x & {"}
End If
End Function

'++LotusScript Development Environment:2:2:SetSelectionExt:22:8
%REM
Sub SetSelectionExt
Description: Like SetSelection, this lets you set up a
notesNoteCollection to search for design elements of a
particular type, but it adds the ability to specify
additional criteria to further narrow the selection.
This can be either in the form of a formula, or "*"
followed by a design element title.
Parameters:
ncoll: the note collection whose selection criteria to set.
strDesignType: the type of design element you're looking for,
e.g. "xpage" or "view".
addlCond: a formula that's "anded" with the selection formula
for the design element type, to narrow down the design elements
returned (e.g. {@Contains("$Flags"; "P")}) or "*" followed by a
|-delimited list of design element names, e.g. "*Reply|Report"
to search for design elements whose name or alias = "Reply" or "Report"
flags: 1 for case-insensitive match of design element names, else 0.
Only has an effect when the "*" syntax of addlCond is used.
%END REM
Sub SetSelectionExt(ncoll As NotesNoteCollection, ByVal strDesignType As String, _
ByVal addlCond$, ByVal flags%)
If Left(addlCond, 1) = "*" Then
Dim nameses
nameses = Split(FullTrim(Mid$(addlCond, 2)), "|")
ForAll aName In nameses
aName = macroquote(LCase(aName))
If flags And 1 Then
aName = LCase(aName)
End If
End ForAll
addlCond = {@Explode($TITLE; "|")}
If flags And 1 Then addlCond = {@Lowercase(} & addlCond & {)}
addlCond = addlCond & "=" & Join(nameses, ":")
End If

SetSelection ncoll, strDesignType
If Len(addlCond) Then
If Len(ncoll.Selectionformula) Then
' this is a weird formula but it's more efficient since the additional condition
' doesn't have to be evaluated unless it's the right design element type, plus
' it lets the addlCond contain multiple statements.
ncoll.Selectionformula = {@If(} & ncoll.Selectionformula & {; @Do(} & addlCond & {); @False)}
Else
ncoll.Selectionformula = addlCond
End If
End If
End Sub


'++LotusScript Development Environment:2:2:SetSelection:14:8
%REM
Sub SetSelection
Description: Given the name of a design element type, e.g. "Form", and a note
collection, sets the note collection to select design elements of that type.
Note: detecting certain design elements requires testing $Flags. This means
it doesn't always work to call SetSelection twice with the same collection
but different design element names. For instance, if you say you want forms
and file resources, you will find no forms because their $Flag items never
contain the character 'g'. Instead do two searches and combine results.
Parameters:
ncoll: the collection to set selection for.
strDesignType: the design element type, e.g. "form", "image".
%END REM
Sub SetSelection(ncoll As NotesNoteCollection, ByVal strDesignType As String)
Select Case LCase(strDesignType)
Case {action}
ncoll.SelectActions = True
Case {agent}
ncoll.SelectAgents = True
Case {applet}
ncoll.Selectallformatelements True
ncoll.SelectionFormula = {@Contains($Flags; "@")}
Case {databasescript}, {database script}
ncoll.SelectDatabaseScript = True
Case {column}
ncoll.SelectMiscIndexElements = True
ncoll.SelectionFormula = {@Contains($Flags; "^")}
Case {data connection}
ncoll.SelectDataConnections = True
Case {file}, {file resource}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = |@Contains($Flags; "g") & !@Matches($Flags; "*{~K[];`_}*")|
Case {hidden file} ' extra file-resource type elements created when XPages are built.
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = |@Contains($Flags; "g") & @Contains($Flags; "~") & !@Matches($Flags; "*{~K[];`_}*")|
Case {custom control}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; "g") & @Contains($Flags; ";")}
Case {theme}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; "g") & @Contains($Flags; "`")}
Case {xpage}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; "g") & @Contains($Flags; "K")}
Case {folder}
ncoll.SelectFolders = True
Case {form}
ncoll.SelectForms = True
Case {frameset}
ncoll.SelectFrameSets = True
Case {navigator}
' ncoll.SelectNavigators = True ' BUG - doesn't work.
ncoll.Selectallindexelements True
ncoll.Selectionformula = |@Matches($Flags; "*G*")|
Case {outline}
ncoll.SelectOutlines = True
Case {page}
ncoll.SelectPages = True
Case {profile}
ncoll.SelectProfiles = True
Case {script library}, {library} ' including web service consumers
ncoll.SelectScriptLibraries = True
Case {libraryonly} ' not including web service consumers
ncoll.SelectScriptLibraries = True
ncoll.SelectionFormula = {!@Contains($FlagsExt; "W")}
Case {web service consumer}
ncoll.SelectScriptLibraries = True
ncoll.SelectionFormula = {@Contains($FlagsExt; "W")}
Case {web service}, {web service provider}
ncoll.SelectMiscCodeElements = True
ncoll.SelectionFormula = |@Contains($Flags; "{")|
Case {sharedfield}, {shared field}
ncoll.SelectSharedFields = True
Case {subform}
ncoll.SelectSubforms = True
Case {view}
' ncoll.SelectViews = True ' BUG - doesn't work.
ncoll.Selectallindexelements True
ncoll.Selectionformula = |!@Matches($Flags; "*{FG^}*")|
Case {wiring}, {wiring properties}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; ":")}
Case {composite application}, {ca xml}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; "|")}
Case {image}
ncoll.SelectImageResources = True
Case {stylesheet}
ncoll.SelectStyleSheetResources = True
Case {db2 access view}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; "z")}
Case {icon}
ncoll.SelectIcon = True
Case {component}
ncoll.SelectMiscFormatElements = True
ncoll.SelectionFormula = {@Contains($Flags; "_")}
End Select
End Sub
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Library DOMUtils
Created Mar 8, 2010 by Andre Guirard/Cambridge/IBM
Description: Various useful functions for working with the built-in DOM
parser of LotusScript. Function names all start with DU_ to help in
context assist.
%END REM

Option Public
Option Declare




'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Function DU_GetTextFromNode(dome As NotesDOMElementNode) As String
Declare Function DU_GetNextElement(elCur As NotesDOMElementNode) As NotesDOMElementNode
Declare Function DU_GetChildNamed(ByVal target$, dome As NotesDOMElementNode) As NotesDOMElementNode
Declare Function DU_GetChildOfType(elParent As NotesDOMElementNode, seekType As Long) As NotesDOMNode
Declare Function DU_GetTextChild(el As NotesDOMElementNode) As NotesDOMTextNode
Declare Function StreamToText(streamIn As NotesStream, ByVal chrset$)
Declare Function TextToStream(szText$, ByVal chrset$) As NotesStream
Declare Function StreamToBase64(streamIn As NotesStream) As String
Declare Function DU_GetChildWithAttr(elParent As NotesDOMElementNode, ByVal targetElement$, ByVal attrName$, ByVal attrValue$, ByVal flags%) As NotesDOMElementNode
Declare Sub Base64ToBinary(strBase64$, streamOut As NotesStream)
Declare Function DU_GetDocNode(node As NotesDOMNode) As NotesDOMDocumentNode

'++LotusScript Development Environment:2:5:(Declarations):0:2

'++LotusScript Development Environment:2:1:DU_GetTextFromNode:6:8
%REM
Function DU_GetTextFromNode
Description: Passed a DOM element node that has a text node as one of its children,
return the text from that node.
%END REM
Function DU_GetTextFromNode(dome As NotesDOMElementNode) As String
'
Dim domn As NotesDOMNode
Set domn = dome.FirstChild
Do Until domn.IsNull
If domn.NodeType = DOMNODETYPE_TEXT_NODE Then
DU_GetTextFromNode = domn.NodeValue
Exit Function
End If
Set domn = domn.NextSibling
Loop
End Function


'++LotusScript Development Environment:2:1:DU_GetNextElement:6:8
%REM
Function DU_GetNextElement
Description: Given a DOM element, find its next sibling that's an element
(in other words, skip over text and other nodes).
%END REM
Function DU_GetNextElement(elCur As NotesDOMElementNode) As NotesDOMElementNode
Dim nTmp As NotesDOMNode
Set nTmp = elCur.Nextsibling
Do Until nTmp.isnull
If nTmp.Nodetype = DOMNODETYPE_ELEMENT_NODE Then
Set DU_GetNextElement = nTmp
Exit function
End If
Set nTmp = nTmp.Nextsibling
Loop
End Function

'++LotusScript Development Environment:2:1:DU_GetChildNamed:6:8
%REM
Function DU_GetChildNamed
Description: given a name and an element, find the first child of that element with the
given tag name.
%END REM
Function DU_GetChildNamed(ByVal target$, dome As NotesDOMElementNode) As NotesDOMElementNode
Dim domn As NotesDOMNode
Set domn = dome.Firstchild
Do Until domn.Isnull
If domn.Nodetype = DOMNODETYPE_ELEMENT_NODE Then
If domn.Nodename = target Then
Set DU_GetChildNamed = domn
Exit Function
End If
End If
Set domn = domn.Nextsibling
Loop
End Function




'++LotusScript Development Environment:2:1:DU_GetChildOfType:14:8
%REM
Function DU_GetChildOfType
Description: Get the first child of an element node that has a particular type.
Arguments:
elParent: node whose child we seek.
seekType: the node type we want. Legal values:
DOMNODETYPE_ELEMENT_NODE (1)
DOMNODETYPE_TEXT_NODE (3)
DOMNODETYPE_CDATASECTION_NODE (4)
DOMNODETYPE_COMMENT_NODE (8)
...and others but you're unlikely to use them.
Returns: the matching node or Nothing if there was no match.
%END REM
Function DU_GetChildOfType(elParent As NotesDOMElementNode, seekType As Long) As NotesDOMNode
Dim node As NotesDOMNode
Set node = elParent.Firstchild
Do Until node.isnull
If node.Nodetype = seekType Then
Set DU_GetChildOfType = node
Exit function
End If
Set node = node.Nextsibling
Loop
End Function

'++LotusScript Development Environment:2:1:DU_GetTextChild:5:8
%REM
Function DU_GetTextChild
Description: Return the first DOM text node which is a child of the specified node.
%END REM
Function DU_GetTextChild(el As NotesDOMElementNode) As NotesDOMTextNode
Dim domn As NotesDOMNode
Set domn = el.FirstChild
Do Until domn.IsNull
If domn.NodeType = DOMNODETYPE_TEXT_NODE Then
Set DU_GetTextChild = domn
Exit Function
End If
Set domn = domn.NextSibling
Loop
End Function

'++LotusScript Development Environment:2:1:StreamToText:7:8
%REM
Function StreamToText
Description: Convert a NotesStream to text in a specified character set.
The default is to interpret NotesStreams as Unicode unless they are
attached to a file; this lets you override that.
%END REM
Function StreamToText(streamIn As NotesStream, ByVal chrset$)
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body")
streamIn.Position = 0
Call mime.SetContentFromBytes(streamIn, "text/plain; charset=" & chrset, ENC_NONE)
StreamToText = mime.ContentAsText
End Function


'++LotusScript Development Environment:2:1:TextToStream:8:8
%REM
Function TextToStream
Description: Produce a stream in a specified character set without opening a file.
Unfortunately the NotesStream.charset attribute will still be the default Unicode,
but the bytes in the stream will be correct. At some point we may be able to do
this by assigning the Charset property and then adding text, but not yet.
%END REM
Function TextToStream(szText$, ByVal chrset$) As NotesStream
Dim session As New NotesSession
Dim streamTmp As NotesStream, doc As NotesDocument, mime As NotesMIMEEntity
Set streamTmp = session.Createstream()
streamTmp.Writetext szText
Set doc = session.Currentdatabase.Createdocument
Set mime = doc.Createmimeentity("Body")
mime.Setcontentfromtext streamTmp, "text/plain; charset=" & chrset, ENC_NONE
Set TextToStream = session.Createstream
mime.Getcontentasbytes TextToStream, false
End Function

'++LotusScript Development Environment:2:1:StreamToBase64:6:8
%REM
Function StreamToBase64
Description: Convert a binary NotesStream to a string of Base64 data.
The output can be used as part of DXL data for importing.
%END REM
Function StreamToBase64(streamIn As NotesStream) As String
On Error GoTo theOldWay
' ReadEncoded function is not documented. In case it doesn't work have a backup.
StreamToBase64 = Replace(streamIn.ReadEncoded(ENC_BASE64, 76), Chr$(13), "")
Exit Function

theOldWay:
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body")
streamIn.Position = 0
Call mime.SetContentFromBytes(streamIn, "image/gif", ENC_NONE)
mime.EncodeContent(ENC_BASE64)
StreamToBase64 = Replace(mime.ContentAsText, Chr$(13), "")
End Function

'++LotusScript Development Environment:2:1:DU_GetChildWithAttr:15:8
%REM
Function DU_GetChildWithAttr
Description: Find a child DOM node with an attribute that has a particular value.
Does not recurse into the tree; looking only for immediate descendants.
Parameters:
elParent: node whose children you want to search.
targetElement: element name of desired child node.
attrName: attribute name you want to check.
attrValue: attribute value of element you're looking for.
flags: string-matching flags to compare attribute, e.g. 1 for case insensitive.
Example:
Set titleItem = DU_GetChildWithAttr(elView, "item", "name", "$title", 1)
finds the first <item> element where name='$title' (case insensitive).
%END REM
Function DU_GetChildWithAttr(elParent As NotesDOMElementNode, ByVal targetElement$, ByVal attrName$, ByVal attrValue$, ByVal flags%) As NotesDOMElementNode
Dim node As NotesDOMNode, elTmp As NotesDOMElementNode
Set node = elParent.Firstchild
Do Until node.Isnull
If node.Nodetype = DOMNODETYPE_ELEMENT_NODE Then
If node.Nodename = targetElement Then
Set elTmp = node
If StrComp(elTmp.Getattribute(attrName), attrValue, flags) = 0 Then
Set DU_GetChildWithAttr = elTmp
Exit Function
End If
End If
End If
Set node = node.Nextsibling
Loop
End Function





'++LotusScript Development Environment:2:2:Base64ToBinary:7:8
%REM
Sub Base64ToBinary
Description: Given a string of base64-encoded data, write into a binary stream we are passed.
This is done rather than creating the stream here and returning it, so that you can
stream directly into a file if you choose.
%END REM
Sub Base64ToBinary(strBase64$, streamOut As NotesStream)
' Given a string of base64 encoded data, this routine decodes and writes the original binary data into a NotesStream
Dim doc As NotesDocument
Dim mime As NotesMIMEEntity
Dim streamIn As NotesStream
Dim db As NotesDatabase
Dim session As New NotesSession

Set db = session.CurrentDatabase
Set doc = db.CreateDocument
Set mime = doc.CreateMIMEEntity("Body") ' the mime classes already know how to do this conversion,
Set streamIn = session.CreateStream
Call streamIn.WriteText(strBase64)
streamIn.Position = 0
Call mime.SetContentFromText(streamIn, "binary", ENC_BASE64)
Call mime.GetContentAsBytes(streamOut, True) ' decode as you stream out the data.
End Sub


'++LotusScript Development Environment:2:1:DU_GetDocNode:6:8
%REM
Function DU_GetDocNode
Description: Find the DOM "document" node from which a given node was derived.
The doc node is needed to create new nodes.
%END REM
Function DU_GetDocNode(node As NotesDOMNode) As NotesDOMDocumentNode
Dim par As NotesDOMNode
Set par = node
Do Until par.Nodetype = DOMNODETYPE_DOCUMENT_NODE
Set par = par.Parentnode
Loop
Set DU_GetDocNode = par
End Function



'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library EmbeddedImage
Created Mar 30, 2010 by Andre Guirard/Cambridge/IBM
Description: Two classes to support getting a list of the embedded images
(pasted or imported graphics) in a document or form-like design element.
%END REM
Option Public
Option Declare
Use "DOMUtils"
Use "ObjectListLite"



'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class EmbeddedImage
Declare Class EmbeddedImageList
Declare Function CalculateImageSize(stream As NotesStream, HeightOut As Long, WidthOut As Long, TypeOut As String) As boolean
Declare Private Function readDWordBE(bytes, ByVal pos%) As Long

'++LotusScript Development Environment:2:5:(Declarations):0:10
%REM
Class EmbeddedImage
Description: Repnesents an image embedded in a rich text item or form/subform/page body.
%END REM
Class EmbeddedImage
Public ImageType As String
m_b64 As String
m_elPic As NotesDOMElementNode ' the <picture> element
m_elImage As NotesDOMElementNode ' the <gif> <jpeg> or whatever element.
m_elItem As NotesDOMElementNode ' the item containing this image, if it's in a rich text item.
m_stream As NotesStream
m_bDirty As Boolean
m_bDeleted As Boolean
m_bGotSize As Boolean ' whether the image dimensions were already calculated
m_height As Long
m_width As Long
m_scaledHeight As Long ' Scaled width in TWIPs
m_scaledWidth As Long

%REM
Sub New
Description: Initialize from a DOM element node <picture>.
%END REM
Sub New(elPic As NotesDOMElementNode)
Set m_elPic = elPic
Set m_elImage = DU_GetChildOfType(m_elPic, DOMNODETYPE_ELEMENT_NODE)
ImageType = m_elImage.nodeName
m_b64 = DU_GetTextFromNode(m_elImage)
m_bGotSize = True
Dim tmp$
tmp = elPic.getattribute("height")
If Right$(tmp, 2) = "px" Then tmp = Left$(tmp, Len(tmp)-2)
m_height = CLng(tmp)
tmp = elPic.getattribute("width")
If Right$(tmp, 2) = "px" Then tmp = Left$(tmp, Len(tmp)-2)
m_width = CLng(tmp)

m_scaledHeight = StrToTWIP(elPic.getattribute("scaledheight"))
m_scaledWidth = StrToTWIP(elPic.getattribute("scaledwidth"))
End Sub

%REM
Function StrToTWIP
Description: Convert a measurement into TWIPs. The string might contain
a unit of measure at the end (if not, inches are assumed).
%END REM
Private Function StrToTWIP(ByVal x$) As Long
If Len(x) Then
Dim CF As Long, crop As Integer
If x Like "*in" Then
CF = RULER_ONE_INCH
crop = 2
ElseIf x Like {*"} Then
CF = RULER_ONE_INCH
crop = 1
ElseIf x Like "cm" then
CF = RULER_ONE_CENTIMETER
crop = 2
Else
CF = RULER_ONE_INCH
End If
StrToTWIP = Round(CDbl(Left$(x, Len(x)-crop)) * CF, 0)
End If
End Function

%REM
Property Get base64
Description: Return the base64-encoded image data.
%END REM
Public Property Get base64 As String
base64 = m_b64
End Property

%REM
Property Set base64
Description: Assign the image data from a base64 string.
%END REM
Public Property Set base64 As String
WriteBase64 base64
End Property

%REM
Sub ReadToStream
Description: The caller passes in a stream into which the image data should be written.
Existing data in the stream are not erased; the caller must make sure the stream is
truncated first if they didn't intend to append the image data to it.
%END REM
Sub ReadToStream(streamOut As NotesStream)
Base64ToBinary m_b64, streamOut
End Sub

%REM
Function Stream
Description: Return a new NotesStream object containing the image data.
%END REM
Function Stream As NotesStream
If m_stream Is Nothing then
Dim session As New NotesSession
Set m_stream = session.Createstream
Base64ToBinary m_b64, m_stream
End If
Set stream = m_stream
End Function

%REM
Sub WriteFromBytes
Description: Replace the image data with data from a stream object.
%END REM
Sub WriteFromBytes(streamIn As NotesStream)
WriteBase64 StreamToBase64(streamIn)
End Sub

%REM
Sub WriteBase64
Description: Replace the image data with base64-encoded data of another image.
%END REM
Sub WriteBase64(b64 As String)
If Not (m_stream Is Nothing) Then Delete m_stream
m_b64 = b64
m_bDirty = True
m_bGotSize = False
m_scaledHeight = 0 ' assume default scaling.
m_scaledWidth = 0
End Sub

%REM
Sub Remove
Description: Delete this image from the document.
%END REM
Sub Remove
If Not m_bDeleted then
m_bDeleted = True
m_bDirty = true
Dim elParent As NotesDOMNode
Set elParent = m_elPic.Parentnode
elParent.Removechild m_elPic
End If
End Sub

%REM
Property Set ScalePercent
Description: Rescale the image to a given size relative to the "actual" size
(i.e. the current scaling is replaced and doesn't affect what happens here).
The percent scaling factor is applied to both dimensions.
%END REM
Public Property Set ScalePercent As Double
If ScalePercent = 100 Then
ResetScaling
Else
ScaledHeight = m_height * (ScalePercent/100.) * Ruler_one_inch / 96.
ScaledWidth = m_width * (ScalePercent/100.) * Ruler_one_inch / 96.
End If
End Property

%REM
Sub CalcSize
Description: Look at the image data to find the picture dimensions.
%END REM
Private Sub CalcSize
If Not m_bGotSize Then
m_bGotSize = True
Dim typTmp$, htmp As Long, wtmp As long
If CalculateImageSize(Stream, htmp, wtmp, typTmp) Then
m_bDirty = (ImageType <> typTmp) Or (m_height <> htmp) Or (m_width <> wtmp)
m_height = htmp
m_width = wtmp
ImageType = typTmp
End If
End If
End Sub

%REM
Function Height
Description: Y-dimension of image, in pixels.
%END REM
Function Height As Long
CalcSize
Height = m_height
End Function

%REM
Function Width
Description: X-dimension of image, in pixels.
%END REM
Function Width As Long
CalcSize
me.Width = m_width
End Function

%REM
Sub ResetScaling
Description: Set the image to default scaling (100%)
%END REM
Sub ResetScaling
If m_scaledHeight Or m_scaledWidth Then
m_scaledHeight = 0
m_scaledWidth = 0
m_bDirty = True
End If
End Sub

%REM
Property Get ScaledHeight
Description: Returns the scaled width of the image in TWIPs, or 0
if the image is at 100%.
%END REM
Public Property Get ScaledHeight As Long
ScaledHeight = m_ScaledHeight
End Property

%REM
Property Get ScaledWidth
Description: Returns the scaled width of the image in TWIPs, or 0
if the image is at 100%.
%END REM
Public Property Get ScaledWidth As Long
ScaledWidth = m_ScaledWidth
End Property

%REM
Property Set ScaledHeight
Description: Set the scaled image height in TWIPS.
%END REM
Public Property Set ScaledHeight As Long
If m_scaledHeight <> ScaledHeight Then
m_scaledHeight = ScaledHeight
m_bDirty = True
End If
End Property

%REM
Property Set ScaledWidth
Description: Scale the image horizonally by setting its width to an absolute
measurement in TWIPs.
%END REM
Public Property Set ScaledWidth As Long
If m_scaledWidth <> ScaledWidth Then
m_scaledWidth = ScaledWidth
m_bDirty = True
End If
End Property

%REM
Property Get ItemName
Description: Returns the name of the rich text field this image is embedded in.
%END REM
Public Property Get ItemName As String
Dim noTmp As NotesDOMNode, elItem As NotesDOMElementNode
Set noTmp = m_elPic.Parentnode
Do While noTmp.Nodetype = DOMNODETYPE_ELEMENT_NODE
If noTmp.Nodename = "item" Then
Set elItem = noTmp
ItemName = elItem.Getattribute("name")
Exit Property
ElseIf noTmp.Nodename = "body" Then
' must be on a form or similar design element
ItemName = "$Body"
Exit Property
End If
Loop
End Property

%REM
Property Get IsDirty
Description: TRUE if the image data or scaling have been modified, or if the
image was deleted.
%END REM
Public Property Get IsDirty As Boolean
IsDirty = m_bDirty
End Property

%REM
Property Get IsDeleted
Description: TRUE if the image was deleted (see Remove method)
%END REM
Public Property Get IsDeleted As Boolean
IsDeleted = m_bDeleted
End Property

%REM
Function Update
Description: Save any pending changes back into the DOM tree. Intended for
internal use.
Return: True if any update was made.
%END REM
Function Update As Boolean
' if the picture was deleted, that counts as an update.
If m_bDeleted Then
Update = True
Exit function
End If

CalcSize
If Not m_bDirty Then Exit Function ' return 0
Dim elNew As NotesDOMElementNode, dn As NotesDOMDocumentNode
If m_elImage.Nodename <> ImageType And ImageType <> "" Then
Set dn = DU_GetDocNode(m_elImage)
Set elNew = dn.Createelementnode(ImageType)
Call elNew.Appendchild(dn.Createtextnode(m_b64))
m_elPic.Replacechild elNew, m_elImage
Set m_elImage = elNew
Else
Dim tn As NotesDOMTextNode
Set tn = DU_GetTextChild(m_elImage)
If tn Is Nothing Then
Set dn = DU_GetDocNode(m_elImage)
Set tn = dn.Createtextnode(m_b64)
m_elImage.Appendchild tn
Else
tn.Nodevalue = m_b64
End If
End If
m_elPic.Setattribute "height", m_height & "px"
m_elPic.Setattribute "width", m_width & "px"
If m_scaledHeight Or m_scaledWidth Then
Dim scHOut As Double, scWOut As Double
If m_scaledHeight = 0 Then
scHOut = (m_height / 96.)
Else
scHOut = (CDbl(m_scaledHeight) / Ruler_one_inch)
End If

If m_scaledWidth = 0 Then
scWOut = (m_width / 96.)
Else
scWOut = (CDbl(m_scaledWidth) / Ruler_one_inch)
End If
m_elPic.Setattribute "scaledheight", scHOut & "in"
m_elPic.Setattribute "scaledwidth", scWOut & "in"
Else
m_elPic.Removeattribute "scaledheight"
m_elPic.Removeattribute "scaledwidth"
End If
Update = True
End Function


End Class


%REM
Class EmbeddedImageList
Description: Represents the embedded images in the rich text of a single document.
%END REM
Class EmbeddedImageList
m_images As ObjectListLite
m_domp As NotesDOMParser
m_db As NotesDatabase
Public ImportOption As Integer ' DXLIMPORTOPTION_xxx

Sub New(doc As NotesDocument)
Dim session As New NotesSession
Dim dxle As NotesDXLExporter
Set dxle = session.Createdxlexporter(doc)
Set m_domp = session.Createdomparser(dxle)
Set m_images = New ObjectListLite
m_images.OwnObjects = True

dxle.Convertnotesbitmapstogif = false
dxle.Outputdoctype = False
dxle.Validationstyle = VALIDATIONSTYLE_NONE
dxle.Process

Dim imageElems As NotesDOMNodeList
Set imageElems = m_domp.Document.Getelementsbytagname("picture")
Dim i As long
For i = 1 To imageElems.Numberofentries
Dim elPic As NotesDOMElementNode
Set elPic = imageElems.Getitem(i)
Dim tmpImg As New EmbeddedImage(elPic)
m_images.Append tmpImg
Next
ImportOption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
Set m_db = doc.Parentdatabase
End Sub

Public Property Get First As EmbeddedImage
Set me.First = m_images.First
End Property

Public Property Get Last As EmbeddedImage
Set me.Last = m_images.Last
End Property

Public Property Get Next As EmbeddedImage
Set me.Next = m_images.Next
End Property

Public Property Get Prev As EmbeddedImage
Set me.Prev = m_images.Prev
End Property

Public Property Get Count As Long
Count = m_images.Count
End Property

%REM
Property Get Image
Description: Retrieve an image from the list using 0-based index.
%END REM
Public Property Get Image(ByVal ind As Long) As EmbeddedImage
Set Image = m_images.get(ind)
End Property

%REM
Property Get IsDirty
Description: Does this thing need saving?
%END REM
Public Property Get IsDirty As Boolean
Dim pos As Long
If m_images.count = 0 Then Exit Property ' False
pos = m_images.Position ' remember pointer position
Dim tmp As EmbeddedImage
Set tmp = m_images.First
Do Until tmp Is Nothing
If tmp.IsDirty Then
IsDirty = True
Exit Do
End If
Set tmp = m_images.Next
Loop
m_images.Position = pos ' restore pointer position
End Property

%REM
Function Save
Description: Save changes. Returns True if any changes were actually made.
%END REM
Function Save(ByVal bSign As Boolean) As NotesDocument
Dim bSave As Boolean
Dim ei As EmbeddedImage
Set ei = me.First
Do Until ei Is Nothing
If ei.Update Then
bSave = True
End If
Set ei = me.Next
Loop

If ImportOption <> DXLIMPORTOPTION_CREATE Then bSave = True

If Not bSave Then Exit Function ' no changes, hence no need to save.

Dim session As New NotesSession
Dim stream As NotesStream, docNew As NotesDocument
Dim strID$, dxli As NotesDXLImporter
On Error Resume next
Kill "c:\kill\tmp.txt"
On Error GoTo 0
Set stream = session.Createstream
stream.Open "c:\kill\tmp.txt"
Set dxli = session.Createdxlimporter(stream, m_db)
dxli.Designimportoption = ImportOption
dxli.Documentimportoption = ImportOption
m_domp.Setoutput stream
m_domp.Serialize
On Error GoTo impErr
dxli.Process
On Error GoTo 0
strID = dxli.Getfirstimportednoteid
If strID <> "" Then
Dim doc As NotesDocument
Set doc = m_db.Getdocumentbyid(strID)
If bSign Then
doc.Sign
doc.Save True, False, True
End If
Set Save = doc
End If
Exit Function
impErr:
Error Err, Error & " - " & dxli.Log
End Function

Sub Delete
Delete m_images
End Sub
End Class
'++LotusScript Development Environment:2:1:CalculateImageSize:1:8
Function CalculateImageSize(stream As NotesStream, HeightOut As Long, WidthOut As Long, TypeOut As String) As boolean
' Calculate dimensions of the image data.
Dim bytArr
Dim w As Long ' width of image
Dim h As Long ' height of image
Dim foundMarker As Boolean
Dim lngOldPos As Long
Dim session As New NotesSession
Dim st As NotesStream
Set st = Stream

tryAgain:
st.Position = 0
HeightOut = 0
WidthOut = 0
TypeOut = ""

bytArr = st.Read(2)
If bytArr(0) = 255 And bytArr(1) = 216 Then
' seems to be a JPG.
' JPG's dimensions stored in a variable location. The code has been verified with JFIF
' file format (the most common format)
foundMarker = False ' Look for the marker that will contain the height and width
While Not foundMarker
bytArr = st.Read(2) ' Grab the next marker
' Look for the marker (in hex) FF C0, FF C1, FF C2, or FF C3
If bytArr(0) = 255 And bytArr(1) >= 192 And bytArr(1) <= 195 Then
bytArr = st.Read(7)
' consisting of the marker length (2 bytes), an ignorable byte,
' the image height (2 bytes hi first), and width.
h = CLng(bytArr(3)) * 256& + CLng(bytArr(4))
w = CLng(bytArr(5)) * 256& + CLng(bytArr(6))
TypeOut = "jpeg"
foundMarker = True ' Exit the while loop
Else ' It's not one of the special markers - skip over it
bytArr = st.Read(2) ' Next two bytes are the marker length
st.Position = st.Position + bytArr(0)*256& + bytArr(1) - 2&
' Skip over that many bytes (minus the 2 byte length already read)
End If
Wend ' Continue until the marker is found
ElseIf bytArr(0) = &h47 And bytArr(1) = &h49 Then
'seems to be a GIF (starting with "GIF89a")
bytArr = st.Read(14)
w = CLng(bytArr(5)) * 256& + CLng(bytArr(4))
h = CLng(bytArr(7)) * 256& + CLng(bytArr(6))
TypeOut = "gif"
foundmarker = true
ElseIf bytArr(0) = 137 And bytArr(1) = 80 Then
' PNG header is decimal 137 80 78 71 13 10 26 10
st.position = 8 ' skip rest of header
bytArr = st.Read(8) ' look for "IHDR", hex 49 48 44 52, after the 4-byte length.
If bytArr(4) = &h49 And bytArr(5) = &h48 And bytArr(6) = &h44 And bytArr(7) = &h52 Then
' found header record. Next is width (4 bytes) and height (4 bytes)
bytArr = st.Read(8)
w = readDWordBE(bytArr, 0)
h = readDWordBE(bytArr, 4)
foundmarker = True
TypeOut = "png"
End If
End If
WidthOut = w
HeightOut = h
CalculateImageSize = foundmarker
End Function


'++LotusScript Development Environment:2:1:readDWordBE:1:8
Private Function readDWordBE(bytes, ByVal pos%) As Long
readDWordBE = (((bytes(pos) * 256& + bytes(pos+1)) * 256&) + bytes(pos+2)) * 256& + bytes(pos+3)
End Function
















'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Library FileResource
Created Mar 8, 2010 by Andre Guirard/Cambridge/IBM
Description: A library containing functions to read and write data from file
resources and related design elements (images, xpages, ...).
%END REM

Option Public
Option Declare

Use "DesignUtils"
Use "DOMUtils"


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class FileResource
Declare Class FileItem
Declare Function FindFileResource(db As NotesDatabase, ByVal resType$, ByVal resName$) As FileResource
Declare Function MakeFileResource(docDes As NotesDocument) As FileResource

'++LotusScript Development Environment:2:5:(Declarations):0:10
Private Const FILE_SEGSIZE = 10240
Private Const ITEMSIZE = 25000
Private Const NL = {
}


%REM
Class FileResource
Description: Represents a design element of the file-resource type or a relative,
such as stylesheet or xpage. The data are manipulated internally using DXL
and DOM.
This class has no objection if you want to also manipulate the other items of the
document, e.g. by using the DOMElement property to get the node representing the
design element, then using the DOM to locate other items and attributes.
However, please use this class and FileItem for manipulation of base-64 encoded
file data items.
%END REM
Class FileResource
m_db As NotesDatabase
m_elElRoot As NotesDOMElementNode
m_elFD As NotesDOMElementNode
m_iMode As Integer
m_fileItem As FileItem
m_domp As NotesDOMParser
Public Log As String
m_fItems List As FileItem ' list of FileItems we've created and returned to caller.

%REM
Sub New
Description: Create a new FileResource.
Arguments:
db: the database containing the design element.
elElement: the DOM element corresponding to the design note (e.g. the <note>
element).
domp: The DOM parser object containing elElement.
%END REM
Sub New(db As NotesDatabase, elElement As NotesDOMElementNode, domp As NotesDOMParser)
Set m_db = db
Set m_elElRoot = elElement
Set m_domp = domp
End Sub

%REM
Property Get DOMElement
Description: Return the element node representing the design element.
%END REM
Public Property Get DOMElement As NotesDOMElementNode
Set DOMElement = m_elElRoot
End Property

%REM
Property Get DOMParser
Description: The DOM parser containing this design element description.
%END REM
Public Property Get DOMParser As NotesDOMParser
Set DOMParser = m_domp
End Property

%REM
Sub findFileItem
Description: Determine whether the $filedata item in this object is
encoded as a <filedata> element or an <item> element.
%END REM
Private Sub findFileItem
Dim sNames
If m_elElRoot.Nodename = "imageresource" Then
sNames = Split("gif,jpeg,png", ",")
Else
sNames = Split("filedata",",")
End If
If m_iMode = 0 Then
m_iMode = 1
ForAll aName In sNames
Set m_elFD = DU_GetChildNamed(aName, m_elElRoot)
If Not (m_elFD Is Nothing) Then Exit sub
End ForAll

' failed to find an element containing file data without CD records.
' Darn! As a backup, look for an <item> element.
m_iMode = 2
Set m_fileitem = New FileItem(Me, m_elElRoot, "$filedata")
End If
End Sub

%REM
Function GetFileItem
Description: Retrieve the FileItem object associated with a CD-record item.
An object will be returned even if the item doesn't exist, which you can
use to create the item via UpdateFile method. Use this only for items other
than the default $FileData item, which you can handle via ReadFileData and
UpdateFileData methods.
%END REM
Function GetFileItem(ByVal itemName$) As FileItem
If StrComp(itemName, "$filedata", 1) = 0 Then
Error 26557, "Do not use FileResource.GetFileItem for the $FileData item."
End If
Set GetFileItem = New FileItem(Me, m_elElRoot, itemName)
End Function

%REM
Function HasItem
Description: Determine whether there's an item element in the note DXL with a
given item name.
Note that the presence of an item doesn't guarantee it's formatted as a file
CD record.
%END REM
Function HasItem(ByVal itemName$) As Boolean
HasItem = Not (DU_GetChildWithAttr(m_elElRoot, "item", "name", itemName, 1) Is Nothing)
End Function

%REM
Sub ReadFileData
Description: Read the file data from the design note. The caller provides a stream
to read into, for ease of streaming directly into a disk file (since you have to
open the file before writing to the stream).
%END REM
Sub ReadFileData(stream As NotesStream)
findFileItem
If m_iMode = 1 then
Dim strFileDat$
strFileDat = DU_GetTextFromNode(m_elFD)
Base64ToBinary strFileDat, stream
Else ' note format!
Set m_fileItem.Stream = stream
m_fileItem.Load
End if
End Sub

%REM
Sub UpdateFileData
Description: Take a binary data stream (it may contain text but we don't care)
and update the DOM representation of the note to store that as the filedata.
The data ends up stored in the $FileData item, whether this is
represented via descriptive format with a <filedata> element, or in note
format with an <item> element. We take our cue from whatever was in the DXL
when we loaded it.
%END REM
Sub UpdateFileData(stream As NotesStream)
findFileItem
If m_iMode = 1 Then
Dim strFileDat$
strFileDat = NL & StreamToBase64(stream)
Dim node As NotesDOMNode
Set node = DU_GetTextChild(m_elFD)
If node Is Nothing Then
Set node = m_domp.Document.Createtextnode(strFileDat)
m_elFD.Appendchild node
Else
node.Nodevalue = strFileDat
End If
Else ' note format!
m_fileItem.UpdateFile stream
End If
End Sub

%REM
Function Save
Description: Save changes to disk by importing the (presumably modified) DOM tree.
%END REM
Function Save As Boolean
Dim session As New NotesSession, dxli As NotesDXLImporter, stream As NotesStream
Set stream = session.Createstream
m_domp.Setoutput stream
Set dxli = session.Createdxlimporter(stream, m_db)
dxli.Designimportoption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
dxli.Inputvalidationoption = VALIDATE_NEVER
dxli.Exitonfirstfatalerror = False
m_domp.Serialize
On Error GoTo oops
Save = True
dxli.Process
If dxli.Importednotecount Then
Dim doc As NotesDocument
Set doc = m_db.Getdocumentbyid(dxli.Getfirstimportednoteid)
doc.Sign
doc.Save true, false, true
End If
resumeHere:
me.Log = dxli.log
Exit Function
oops:
Save = False
Resume resumeHere
End Function

%REM
Sub DeleteItem
Description: Delete an item with a specified name from the note data.
%END REM
Sub DeleteItem(ByVal itemName$)
Dim elItem As NotesDOMElementNode, elNext As NotesDOMElementNode
Set elItem = DU_GetChildWithAttr(m_elElRoot, "item", "name", itemName, 1)
If Not (elItem Is Nothing) Then
Do
Set elNext = elItem.Nextsibling
m_elElRoot.Removechild elItem
If elNext.Nodetype = DOMNODETYPE_ELEMENT_NODE Then
If elNext.Nodename <> "item" Then Exit Do
if StrComp(elNext.Getattribute("name"), itemName, 1) Then Exit Do
End If
Delete elItem
Set elItem = elNext
Loop Until elNext.Isnull
End If
On Error GoTo nevermind
Dim fi As FileItem
Set fi = m_fItems(LCase(itemName))
Erase m_fItems(LCase(itemName))
Delete fi ' because we don't trust LS memory mgmt.
nevermind:
Exit sub
End Sub

Sub Delete
On Error Resume Next
ForAll thing In m_fItems
Delete thing
End ForAll
End Sub

%REM
Function RegisterFileItem
Description: For internal use -- lets the FileItem class notify us that it's
referencing our DOM tree so that we can delete the object if we erase the
corresponding item element.
%END REM
Sub RegisterFileItem(x As FileItem)
Set m_fItems(LCase(x.itemName)) = x
End Sub

%REM
Property Get MimeCharSet
Description: se this to read the $MimeCharSet item and discover what character set
was used to encode the text file data (if it is text). Note some design elements
don't have this because it's assumed based on the design element type.
%END REM
Property Get MimeCharSet As String
Dim tmp$
tmp = m_elElRoot.Getattribute("charset") ' sometimes it is this easy...
If tmp = "" then
Dim elItem As NotesDOMElementNode
Set elItem = DU_GetChildWithAttr(m_elElRoot, "item", "name", "$MimeCharSet", 1)
If Not (elItem Is Nothing) Then
Dim elText As NotesDOMElementNode
Set elText = DU_GetChildNamed("text", elItem)
If Not (elText Is Nothing) Then
tmp = DU_GetTextFromNode(elText)
End If
End If
End If
MimeCharSet = tmp
End Property
End Class


%REM
Class FileItem
Description: Represents a Notes item containing file data encoded as CD records
in base64 format. This is the representation used in "note format" DXL (which is
also the fallback for design elements without a descriptive representation).
%END REM
Class FileItem
a_ItemName As String
Public Stream As NotesStream ' the decoded file data
m_fileext As Variant ' array of bytes
m_segCount As Long
m_segsLoaded As Long
m_fileLen As Long
m_elItem As NotesDOMElementNode
m_elNote As NotesDOMElementNode
m_domd As NotesDOMDocumentNode

%REM
Sub New
Description: Arguments are the parsed DOM node of the element representing a
design element, and the name of the composite item you would like to read,
modify or create.
%END REM
Sub New(parent As FileResource, elNote As NotesDOMElementNode, ByVal itemName$)
Set m_elNote = elNote
Set m_elItem = DU_GetChildWithAttr(elNote, "item", "name", itemName, 1)
If Not (m_elItem Is Nothing) Then
a_itemName = m_elItem.Getattribute("name")
Else
a_itemName = itemName
End If
Dim node As NotesDOMNode
Set node = m_elNote.Parentnode
While node.Nodetype <> DOMNODETYPE_DOCUMENT_NODE
Set node = node.Parentnode
Wend
Set m_domd = node
parent.RegisterFileItem Me ' make sure the design element knows about us.
' (in case someone gets smart and invokes the constructor directly
' instead of using the nice methods we've provided).
End Sub

%REM
Sub Load
Description: Populate the Stream object with the decoded contents of the file.
Note you can assign Stream first with your own object, if you want to store
the result in a file. Note that nothing is said here about character set;
you data are treated as binary. If you supply a stream that's attached to a
file, you can specify the character set when you open the file. Otherwise,
if you need to read the contents as character data, see StreamToText function
(not method!).
If you supply a stream, it will be truncated.
%END REM
Sub Load
If Stream Is Nothing Then
Dim session As New NotesSession
Set stream = session.createstream
Else
stream.Truncate
End If
If m_elItem Is Nothing Then Exit Sub ' no item, leave stream empty.
Dim elRaw As NotesDOMElementNode, elItem As NotesDOMElementNode
Set elRaw = DU_getChildNamed("rawitemdata", m_elItem)
Dim streamRecs As NotesStream
Set elItem = m_elItem

Set streamRecs = getStream(elRaw)
LoadHeader StreamRecs
Do While m_segsLoaded < m_segCount
If streamRecs.Iseos Then
Set elItem = DU_GetNextElement(elItem)
If elItem.Nodename <> "item" Or elItem.Getattribute("name") <> a_itemname Then
Error 17665, "File data incomplete in FileItem.Load"
End If
Set elRaw = DU_GetChildNamed("rawitemdata", elItem)
Set streamRecs = getStream(elRaw)
End If
LoadSegment streamRecs
Loop
End Sub

%REM
Function getStream
Description: Get a stream by decoding the base64 data in a <rawitemdata>.
%END REM
Private Function getStream(elRaw As NotesDOMElementNode) As NotesStream
Dim session As New NotesSession
Set getstream = session.Createstream
Dim szBase64 As String
szBase64 = DU_GetTextFromNode(elRaw)
Call Base64ToBinary(szBase64, getstream)
getstream.Position = 0
End Function

%REM
Sub loadHeader
Description: internal function to read the first CD record in the file data,
which contains the number of file segments to follow and the total file size.
This also sets the m_fileExt property, preserving any file suffix stored with
the file data.
%END REM
Private Sub LoadHeader(streamIn As NotesStream)
Dim bytes
bytes = streamIn.Read(24)
Dim sufxLen%
sufxLen = readword(bytes, 6)
m_fileLen = readDWord(bytes, 8)
m_segCount = readDWord(bytes, 12)
If sufxLen Then
m_fileExt = streamIn.Read(sufxLen)
If sufxLen And 1 Then
streamIn.Position = streamIn.Position + 1
End If
End If
End Sub

%REM
Sub LoadSegment
Description: Load a record of file data. The buffer position is at the
beginning of the record header.
%END REM
Private Sub LoadSegment(streamIn As NotesStream)
Dim bytes
bytes = streamIn.Read(18) ' read the entire record header
Dim dataSize As Long
Dim segSize As Long
dataSize = readword(bytes, 6) ' number of bytes of file data in the record.
segSize = readWord(bytes, 8) ' dataSize + any fill we have to skip.
bytes = streamIn.Read(dataSize)
Stream.Write bytes
If segSize > dataSize Then ' skip fill bytes
streamIn.Position = streamIn.Position + (segSize-dataSize)
End If
m_segsLoaded = m_segsLoaded + 1
End Sub

%REM
Function readword, readDWord
Description: Read an integer from a byte array (low byte first)
Arguments:
bytes: array to read from.
pos: array index of low-order byte.
%END REM
Private Function readword(bytes, ByVal pos%) As Integer
readword = bytes(pos) + 256*bytes(pos+1)
End Function

Private Function readDWord(bytes, ByVal pos%) As Long
readDWord = (((bytes(pos+3) * 256& + bytes(pos+2)) * 256&) + bytes(pos+1)) * 256& + bytes(pos)
End Function

%REM
Function writeWord, writeDWord
Description: store an integer value into a byte array in ODS order (low byte first)
Arguments:
bytes: byte array into which to write.
pos: array index to place first byte of number.
valu: number to write.
%END REM
Private Sub writeWord(bytes, ByVal pos%, ByVal valu As Integer)
bytes(pos) = valu and 255
bytes(pos+1) = valu \ 256
End Sub

Private Sub writeDWord(bytes, ByVal pos%, ByVal valu As Long)
bytes(pos) = valu and 255
Dim i%
For i = 1 To 3
valu = valu \ 256
bytes(pos+i) = valu And 255
Next
End Sub

%REM
Sub WriteHeader
Description: Create the ODS structure for a filedata header.
Arguments:
streamOut: output buffer
fiLen: File length in bytes.
fileExt: EMPTY if there is no file extension to store, else a byte array
with the file extension in LMBCS.
%END REM
Private Sub WriteHeader(streamOut As NotesStream, ByVal FiLen As Long, fileExt)
m_segCount = (FiLen+FILE_SEGSIZE-1) \ FILE_SEGSIZE
Dim sfLen%, recLen%
If Not IsEmpty(fileExt) Then
sfLen = UBound(fileExt) + 1
End if
recLen = sfLen + (sfLen And 1) + 24
reDim bytes(reclen-1) As Byte
bytes(0) = &h61
bytes(1) = 0
writeDWord bytes, 2, recLen
writeWord bytes, 6, sfLen
writeDWord bytes, 8, fiLen
writeDWord bytes, 12, m_segCount
If sfLen Then ' there is a file extension (unusual).
Dim i%
For i = 0 To UBound(fileExt)
bytes(i+24) = fileExt(i)
Next
End If
streamOut.Write bytes
End Sub

%REM
Sub WriteSegment
Description: Stream out to buffer a "file segment" CD record, with a 18 byte
record header followed by file data and maybe a fill byte for alignment.
%END REM
Private Sub WriteSegment(streamOut As NotesStream, streamIn As NotesStream)
Dim bytes, cbytes%
bytes = streamIn.Read(FILE_SEGSIZE)
cBytes = 1+UBound(bytes)
Dim header(17) As Byte
header(0) = &h60
header(1) = 0
writeDword header, 2, cBytes + 18
writeWord header, 6, cBytes
writeWord header, 8, cBytes + (cBytes And 1)
streamOut.write header
streamOut.write bytes
If cbytes And 1 Then ' alignment filler
Dim aByte(0) As Byte
streamOut.write aByte
End If
End Sub

%REM
Sub UpdateFile
Description: Take binary file data as input, and create or update the <item>
element to store that data as CD records. The streamIn buffer must contain only
the data to be written (current position in the stream is ignored).
%END REM
Sub UpdateFile(streamIn As NotesStream)
Dim elNextSib As NotesDOMElementNode, elTmp As NotesDOMElementNode
Dim session As New NotesSession

' delete all items with the same name
If Not (m_elItem Is Nothing) Then
Set elTmp = DU_GetNextElement(m_elItem)
While elTmp.Nodename = "item" And elTmp.Getattribute("name") = a_itemName
Set elNextSib = DU_Getnextelement(elTmp)
m_elNote.Removechild elTmp
Delete elTmp
Set elTmp = elNextSib
Wend
End If

Set Stream = streamIn
streamIn.Position = 0
Dim streamOut As NotesStream, txB64 As NotesDOMTextNode, frag As NotesDOMDocumentFragmentNode
Dim segLength&
Set streamOut = session.Createstream
WriteHeader Streamout, streamIn.Bytes, m_fileext

While Not streamIn.Iseos
' is there room for the remaining bytes in the current item?
segLength = streamIn.bytes-streamIn.Position
If segLength > FILE_SEGSIZE+18 Then
segLength = FILE_SEGSIZE+18
End If
If streamOut.bytes + segLength > ITEMSIZE Then
' can't fit this segment in; save what we have so far and start again
If frag Is Nothing Then
Set frag = m_domd.Createdocumentfragmentnode
End if
AddItem frag, streamOut
streamOut.Truncate ' make room for more segments.
End If
WriteSegment streamOut, streamIn
Wend
If frag Is Nothing And Not (m_elItem Is Nothing) Then
' this can be written in a single segment
Dim elRaw As NotesDOMElementNode
Set elRaw = DU_GetChildNamed("rawitemdata", m_elItem)
Set txB64 = DU_GetTextChild(elRaw)
streamOut.Position = 0
txB64.Nodevalue = NL & StreamToBase64(streamOut)
Else
If frag Is Nothing Then
Set frag = m_domd.Createdocumentfragmentnode
End If
AddItem frag, streamOut
Set elTmp = frag.Firstchild
If m_elItem Is Nothing Then
m_elNote.AppendChild frag
Else
m_elNote.Replacechild frag, m_elItem
End If
Set m_elItem = elTmp
End If
End Sub

%REM
Sub AddItem
Description: Take the stream buffer containing CD records, convert it to
base64 notation, and create a new item element containing that data.
Add it to the document fragment which contains possibly
multiples of these item elements with the same name.
%END REM
Private Sub AddItem(frag As NotesDOMDocumentFragmentNode, streamIn As NotesStream)
Dim elItem As NotesDOMElementNode, elRaw As NotesDOMElementNode
Set elItem = m_domd.Createelementnode("item")
elItem.Setattribute "name", a_ItemName
elItem.Setattribute "sign", "true"
Set elRaw = m_domd.Createelementnode("rawitemdata")
elRaw.Setattribute "type", "1"
Call elRaw.Appendchild(m_domd.Createtextnode(NL & StreamToBase64(streamIn)))
Call elItem.Appendchild(elRaw)
frag.Appendchild elItem
End Sub

Public Property Get ItemName As String
ItemName = a_ItemName
End Property
End Class
'++LotusScript Development Environment:2:1:FindFileResource:13:8
%REM
Function FindFileResource
Description: Search a database for a design element of a given name and type
(type being, for instance, "xpage" or "stylesheet"). This is only suitable
for design elements of the type that contain binary-encoded file data,
which is usually but not always in an item named $FileData.
NOTE: This has the same drawback as NotesDatabase.GetView and the
like, in that if there are multiple design elements with the same
name you will only find one of them. It may be better to use
NotesNoteCollection to locate the design elements yourself and
call MakeFileResource instead.
%END REM
Function FindFileResource(db As NotesDatabase, ByVal resType$, ByVal resName$) As FileResource
Dim nnc As NotesNoteCollection, session As New NotesSession
Set nnc = db.Createnotecollection(false)
SetSelectionExt nnc, resType, "*" & resName, 1
nnc.Buildcollection
If nnc.Count Then
Dim docDes As NotesDocument
Set docDes = db.Getdocumentbyid(nnc.Getfirstnoteid)
Set FindFileResource = MakeFileResource(docDes)
Delete docDes
End If
End Function




'++LotusScript Development Environment:2:1:MakeFileResource:8:8
%REM
Function MakeFileResource
Description: Given the NotesDocument handle of a design element (which you've
probably found using NotesNoteCollection), creates a FileResource object
representing that design element. Note this is only suitable for use with
design elements of the "file resource" type.
%END REM
Function MakeFileResource(docDes As NotesDocument) As FileResource
Dim session As New NotesSession
Dim dxle As NotesDXLExporter, domp As NotesDOMParser
Set dxle = session.Createdxlexporter(docDes)
Set domp = session.Createdomparser(dxle)
dxle.Outputdoctype = False
dxle.Process
Dim domd As NotesDOMDocumentNode
Set domd = domp.Document
Set MakeFileResource = New FileResource(docDes.Parentdatabase, domd.Documentelement, domp)
End Function



'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library ObjectList
Created Mar 30, 2010 by Andre Guirard/Cambridge/IBM
Description: Maintain a doubly linked list of objects of any type.
%END REM
Option Public
Option Declare



'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class ObjectList
Declare Private Class ObjectListNode

'++LotusScript Development Environment:2:5:(Declarations):0:10
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Class ObjectList
Description: A list of objects of whatever type.
%END REM
Class ObjectList
m_first As ObjectListNode
m_last As ObjectListNode
m_current As ObjectListNode ' last-accessed node in the list.
m_pos As Long ' "current" position in the list.
m_count As Long
Public OwnObjects As Boolean ' if TRUE, delete the objects in the list when the list is deleted.

%REM
Sub Append
Description: Add a value at the end of the list. The added node becomes the new "current" position.
%END REM
Sub Append(valu)
Dim tmp As New ObjectListNode(valu)
If m_count Then
Set m_last.Next = tmp
Set tmp.prev = m_last
Else
Set m_first = tmp
Set m_current = tmp
m_pos = 0
End If
Set m_last = tmp
Set m_current = tmp
m_pos = m_count
m_count = m_count + 1
End Sub

%REM
Sub AddAt
Description: Insert a value at a specified index position (0-based).
The new node becomes the new "current" node.
%END REM
Sub AddAt(ByVal ind As Long, valu)
If ind = m_count Then
me.Append valu
Else
Dim nuNode As New ObjectListNode(valu)
If ind = 0 Then
' insert at start of list
Set nuNode.Next = m_first
Set m_first.Prev = nuNode
Set m_first = nuNode
Else
Position = ind-1
Set nuNode.Prev = m_current
Set nuNode.Next = m_current.Next
Set nuNode.Next.Prev = nuNode
Set m_current.Next = nuNode
End If
Set m_current = nuNode
m_pos = ind
m_count = m_count + 1
End If
End Sub

%REM
Sub AddAfter
Description: Add the object newObj to the list after the object
existingObj which is assumed to already be in there.
%END REM
Sub AddAfter(existingObj, newObj)
If (RepositionTo(existingObj)) then
AddAt m_pos + 1, newObj
Else
Error 15440, "ObjectList.AddAfter failed to find existing object."
End If
End Sub

%REM
Property Get Count
Description: Return number of elements in the list
%END REM
Public Property Get Count As Long
count = m_count
End Property

%REM
Property Get First
Description: Return the first object in the list.
%END REM
Public Property Get First
If m_count = 0 Then
Set First = Nothing
Else
m_pos = 0
Set m_current = m_first
Set First = m_current.Value
End If
End Property

%REM
Property Get Last
Description: Returns the last node in the list.
%END REM
Public Property Get Last
If m_count = 0 Then
Set Last = Nothing
Else
m_pos = m_count - 1
Set m_current = m_last
Set Last = m_current.Value
End If
End Property

%REM
Property Get Position
Description: The zero-based index of the "current" list node.
%END REM
Public Property Get Position As Long
Position = m_pos
End Property

%REM
Property Set Position
Description: Reposition by number.
%END REM
Public Property Set Position As Long
' try to find desired node by counting from the closest known location:
' forward from start, backward from current, forward from current, or backward from end.
If Position >= m_count Or Position < 0 Then
' refuse to set a value that's out of range.
Error 9, {ObjectList subscript out of range}
End If

If Position = 0 Then
Set m_current = m_first
m_pos = 0
ElseIf position = m_pos + 1 then
Set m_current = m_current.Next
m_pos = Position
ElseIf Position <> m_pos then
Dim mindif As Long

' how far is it from current position?
mindif = Abs(m_pos-Position)

' how far from the start?
If Position < mindif Then
mindif = Position
Set m_current = m_first
m_pos = 0
End If

' how far from the end?
If m_count-Position-1 < mindif Then
Set m_current = m_last
m_pos = count-1
End If

' current pointer is at the closest position we could easily find.
If Position < m_pos Then
' go backward
While Position < m_pos
Set m_current = m_current.Prev
m_pos = m_pos - 1
Wend
Else ' forward
While Position > m_pos
Set m_current = m_current.Next
m_pos = m_pos + 1
Wend
End If
End If
End Property

Function Get(ByVal ind As Long)
If ind >= m_count Or ind < 0 Then
Set me.Get = Nothing
Else
Position = ind
Set me.Get = m_current.Value
End If
End Function

Public Property Get Next
If m_pos < m_count-1 Then
Set m_current = m_current.Next
m_pos = m_pos + 1
Set me.Next = m_current.Value
Else
Set me.Next = Nothing
End If
End Property

Public Property Get Prev
If m_pos > 0 Then
Set m_current = m_current.Prev
m_pos = m_pos - 1
Set me.Prev = m_current.Value
Else
Set me.Prev = Nothing
End If
End Property

%REM
Function RepositionTo
Description: Search the list for a particular node and make that the "current" node.
Returns True if the node was found.
%END REM
Function RepositionTo(obj) As Boolean
If m_count Then
' first try the likeliest nodes: the first, last, current, and just before and after current.
If obj Is m_current.Value Then
RepositionTo = True
ElseIf obj is m_first.Value Then
m_pos = 0
Set m_current = m_first
RepositionTo = True
ElseIf obj is m_last.Value Then
m_pos = m_count - 1
Set m_current = m_last
RepositionTo = True
Else
Dim pos As Long, tmp As ObjectListNode
If m_pos < m_count - 1 Then
If m_current.Next.Value Is obj Then
Set m_current = m_current.Next
m_pos = m_pos + 1
RepositionTo = True
Exit Function
End if
End If
If m_pos Then
If m_current.Prev.value Is obj Then
Set m_current = m_current.Prev
m_pos = m_pos - 1
RepositionTo = True
Exit Function
End If
End If

' search forward from current position, skipping the one already checked
If m_pos < m_count - 2 then
pos = m_pos+2
Set tmp = m_current.next.next
Do Until tmp Is Nothing
If obj Is tmp.Value Then
foundit:
m_pos = pos
Set m_current = tmp
RepositionTo = True
Exit Function
End If
Set tmp = tmp.Next
pos = pos + 1
Loop
End If

' not found: search backward from current.
If m_pos > 1 then
pos = m_pos-2
Set tmp = m_current.Prev.Prev
Do Until tmp Is Nothing
If obj Is tmp.Value Then GoTo foundit
Set tmp = tmp.Prev
pos = pos - 1
Loop
End If
End If
End If
End Function

%REM
Property Get Current
Description: Return the current (last-referenced) object.
%END REM
Public Property Get Current
If m_count = 0 Then
Set Current = Nothing
Else
Set current = m_current.value
End If
End Property

%REM
Sub RemoveCurrent
Description: Delete the current object, making the next object current (or
the last object, if there is no next object).
%END REM
Sub RemoveCurrent
If m_count = 0 Then Exit Sub ' nothing to remove
Dim doomed As ObjectListNode
Set doomed = m_current
If m_pos = 0 Then
Set m_first = doomed.next
Else
Set m_current.Prev.Next = doomed.Next
End If
If m_pos = m_count-1 Then
Set m_last = doomed.prev
Set m_current = m_last
m_pos = m_pos - 1
Else
Set m_current = doomed.Next
Set doomed.Next.Prev = doomed.Prev
End If
If OwnObjects Then
If Not (doomed.value Is Nothing) Then Delete doomed.value
End If
Delete doomed
m_count = m_count - 1
End Sub

%REM
Function Remove
Description: Remove a given object from the list. Returns True if the object was there.
%END REM
Function Remove(obj) As Boolean
me.Remove = RepositionTo(obj)
If me.Remove Then
RemoveCurrent
End If
End Function

%REM
Sub RemoveAt
Description: Remove the element at a given index (0-based)
%END REM
Sub RemoveAt(ByVal index As Long)
Position = index
RemoveCurrent
End Sub

Sub Delete
On Error Resume Next
Do Until m_first Is Nothing
Set m_current = m_first.next
If OwnObjects Then Delete m_first.value
Delete m_first
Set m_first = m_current
Loop
End Sub

%REM
Function ExtractCurrent
Description: Remove something from the list without deleting the object
(in case it is "owned").
%END REM
Function ExtractCurrent
Set ExtractCurrent = Current
If OwnObjects Then ' make a temporary exception.
OwnObjects = False
RemoveCurrent
OwnObjects = True
Else
RemoveCurrent
End If
End Function
End Class

%REM
Class ObjectNode
Description: Internal class to serve as a node in a doubly linked list,
containing a pointer to the user's object, and links to other nodes.
%END REM
Private Class ObjectListNode
Public Value As Variant ' but it is an object
Public Next As ObjectListNode
Public Prev As ObjectListNode

Sub New(datum)
Set Value = datum
End Sub
End Class
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library ObjectListLite
Created Mar 30, 2010 by Andre Guirard/Cambridge/IBM
Description: Maintain a doubly-linked list of objects of any type.
%END REM
Option Public
Option Declare



'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class ObjectListLite
Declare Private Class ObjectListNode

'++LotusScript Development Environment:2:5:(Declarations):0:10

%REM
Class ObjectListLite
Description: A list of objects of whatever type, leaving out the functionality to search for
nodes in the list (see ObjectList class).
%END REM
Class ObjectListLite
m_first As ObjectListNode
m_last As ObjectListNode
m_current As ObjectListNode ' last-accessed node in the list.
m_pos As Long ' "current" position in the list.
m_count As Long
Public OwnObjects As Boolean ' if TRUE, delete the objects in the list when the list is deleted.

%REM
Sub Append
Description: Add a value at the end of the list. The added node becomes the new "current" position.
%END REM
Sub Append(valu)
Dim tmp As New ObjectListNode(valu)
If m_count Then
Set m_last.Next = tmp
Set tmp.prev = m_last
Else
Set m_first = tmp
Set m_current = tmp
m_pos = 0
End If
Set m_last = tmp
Set m_current = tmp
m_pos = m_count
m_count = m_count + 1
End Sub

%REM
Sub AddAt
Description: Insert a value at a specified index position (0-based).
The new node becomes the new "current" node.
%END REM
Sub AddAt(ByVal ind As Long, valu)
If ind = m_count Then
me.Append valu
Else
Dim nuNode As New ObjectListNode(valu)
If ind = 0 Then
' insert at start of list
Set nuNode.Next = m_first
Set m_first.Prev = nuNode
Set m_first = nuNode
Else
Position = ind-1
Set nuNode.Prev = m_current
Set nuNode.Next = m_current.Next
Set nuNode.Next.Prev = nuNode
Set m_current.Next = nuNode
End If
Set m_current = nuNode
m_pos = ind
m_count = m_count + 1
End If
End Sub

%REM
Property Get Count
Description: Return number of elements in the list
%END REM
Public Property Get Count As Long
count = m_count
End Property

%REM
Property Get First
Description: Return the first object in the list.
%END REM
Public Property Get First
If m_count = 0 Then
Set First = Nothing
Else
m_pos = 0
Set m_current = m_first
Set First = m_current.Value
End If
End Property

%REM
Property Get Last
Description: Returns the last node in the list.
%END REM
Public Property Get Last
If m_count = 0 Then
Set Last = Nothing
Else
m_pos = m_count - 1
Set m_current = m_last
Set Last = m_current.Value
End If
End Property

%REM
Property Get Position
Description: The zero-based index of the "current" list node.
%END REM
Public Property Get Position As Long
Position = m_pos
End Property

%REM
Property Set Position
Description: Reposition by number.
%END REM
Public Property Set Position As Long
' try to find desired node by counting from the closest known location:
' forward from start, backward from current, forward from current, or backward from end.
If Position >= m_count Or Position < 0 Then
' refuse to set a value that's out of range.
Error 9, {ObjectList subscript out of range}
End If

If Position = 0 Then
Set m_current = m_first
m_pos = 0
ElseIf position = m_pos + 1 then
Set m_current = m_current.Next
m_pos = Position
ElseIf Position <> m_pos then
Dim mindif As Long

' how far is it from current position?
mindif = Abs(m_pos-Position)

' how far from the start?
If Position < mindif Then
mindif = Position
Set m_current = m_first
m_pos = 0
End If

' how far from the end?
If m_count-Position-1 < mindif Then
Set m_current = m_last
m_pos = count-1
End If

' current pointer is at the closest position we could easily find.
If Position < m_pos Then
' go backward
While Position < m_pos
Set m_current = m_current.Prev
m_pos = m_pos - 1
Wend
Else ' forward
While Position > m_pos
Set m_current = m_current.Next
m_pos = m_pos + 1
Wend
End If
End If
End Property

Function Get(ByVal ind As Long)
If ind >= m_count Or ind < 0 Then
Set me.Get = Nothing
Else
Position = ind
Set me.Get = m_current.Value
End If
End Function

Public Property Get Next
If m_pos < m_count-1 Then
Set m_current = m_current.Next
m_pos = m_pos + 1
Set me.Next = m_current.Value
Else
Set me.Next = Nothing
End If
End Property

Public Property Get Prev
If m_pos > 0 Then
Set m_current = m_current.Prev
m_pos = m_pos - 1
Set me.Prev = m_current.Value
Else
Set me.Prev = Nothing
End If
End Property


%REM
Property Get Current
Description: Return the current (last-referenced) object.
%END REM
Public Property Get Current
If m_count = 0 Then
Set Current = Nothing
Else
Set current = m_current.value
End If
End Property

%REM
Sub RemoveCurrent
Description: Delete the current object, making the next object current (or
the last object, if there is no next object).
%END REM
Sub RemoveCurrent
If m_count = 0 Then Exit Sub ' nothing to remove
Dim doomed As ObjectListNode
Set doomed = m_current
If m_pos = 0 Then
Set m_first = doomed.next
Else
Set m_current.Prev.Next = doomed.Next
End If
If m_pos = m_count-1 Then
Set m_last = doomed.prev
Set m_current = m_last
m_pos = m_pos - 1
Else
Set m_current = doomed.Next
Set doomed.Next.Prev = doomed.Prev
End If
If OwnObjects Then
If Not (doomed.value Is Nothing) Then Delete doomed.value
End If
Delete doomed
m_count = m_count - 1
End Sub

%REM
Function ExtractCurrent
Description: Remove something from the list without deleting the object
(if it is "owned"). Return the extracted object.
%END REM
Function ExtractCurrent
Dim bOwn As Boolean
Set ExtractCurrent = Current
' make a temporary exception to owning while we remove this
bOwn = OwnObjects
OwnObjects = false
RemoveCurrent
OwnObjects = bOwn
End Function

%REM
Sub RemoveAt
Description: Remove the element at a given index (0-based)
%END REM
Sub RemoveAt(ByVal index As Long)
Position = index
RemoveCurrent
End Sub

Sub Delete
On Error Resume Next
Do Until m_first Is Nothing
Set m_current = m_first.next
If OwnObjects Then Delete m_first.value
Delete m_first
Set m_first = m_current
Loop
End Sub
End Class

%REM
Class ObjectNode
Description: Internal class to serve as a node in a doubly linked list,
containing a pointer to the user's object, and links to other nodes.
%END REM
Private Class ObjectListNode
Public Value As Variant ' but it is an object
Public Next As ObjectListNode
Public Prev As ObjectListNode

Sub New(datum)
Set Value = datum
End Sub
End Class
'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2009 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

' ReportGenerator makes it easier to compile and present reports using Notes rich text.
' It supports filling in tables that you read from a Page design element, figures out
' where paragraph breaks are needed instead of line breaks (because there's a limit
' to the number of paragraphs and they are slower than line breaks, so we want to use
' line breaks where possible), breaks up long strings into multiple chunks to avoid
' exceeding an internal limit of the AppendText method, and allows for display of the
' resulting report by email message, report window in the Notes client, just saving the
' document, or messagebox.
Option Declare
Option Public

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class ReportGenerator
Declare Sub Initialize

'++LotusScript Development Environment:2:5:(Declarations):0:10
'Class_ReportGenerator v2.0

' A default set of styles are available for use in the report -- the caller can also define their own,
' or customize these by setting their properties in the calling code.
Dim RGENstyleTitle As NotesRichTextStyle ' big bold report title
Dim RGENstyleSubtitle As NotesRichTextStyle ' slightly smaller line to appear under title
Dim RGENstyleHeader As NotesRichTextStyle ' beginning of a section
Dim RGENstyleNormal As NotesRichTextStyle ' regular text
Dim RGENstyleEmphasis As NotesRichTextStyle ' emphasized text
Dim RGENstyleError As NotesRichTextStyle ' screaming red error message
Dim RGENstyleFixed As NotesRichTextStyle ' fixed-width font

Dim RGENpstyleCenter As NotesRichTextParagraphStyle
Dim RGENpstyleLeft As NotesRichTextParagraphStyle
Dim RGENpstyleIndent As NotesRichTextParagraphStyle

Private Const PARLIMIT = 300000
Private Const CHUNKSIZE = 14000 ' max chars to send to AppendText at once.
Private Const NEWLINE = {
}

Const DISPLAYTYPE_TAB = 0 ' in its own window using Report form
Const DISPLAYTYPE_MEMO = 1 ' in its own window in a Memo in the user's mail file
Const DISPLAYTYPE_MSGBOX = 2
Const DISPLAYTYPE_DIALOG = 3 ' in a dialog window using DialogReport form
Const DISPLAYTYPE_QUIET = 4 ' don't display (use for back-end code).

Const ERR_RGEN_LONGLINE = 20448
Private Const ERR_RGEN_LONGLINE_TEXT = "ReportGenerator: Too many characters without line break."
Const ERR_RGEN_NESTEDTABLE = 20049
Private Const ERR_RGEN_NESTEDTABLE_TEXT = "ReportGenerator: A table is already open (nested tables not supported -- sorry!)"


Class ReportGenerator
m_db As NotesDatabase
m_docReport As NotesDocument
m_rti As NotesRichTextItem
m_started As Boolean
m_buffer As String ' holding area for characters not yet added to the output.
m_extraChars As Long
m_displaytype As Integer
m_displayed As Boolean
m_rtnavTable As NotesRichTextNavigator ' if a table has been inserted, position within the table.
m_table As NotesRichTextTable
m_bInserting As Boolean

Public WindowTitle As String
Public AutoDisplay As Boolean ' if True the report will be displayed on exit even if the Display method is not explicitly called.

Sub New(ByVal dtype As Integer, ByVal formName$, ByVal strBodyItem$, existingDoc As NotesDocument)
Dim strForm$
Dim session As New NotesSession
m_displaytype = dtype
If dtype = DISPLAYTYPE_MEMO Then
Set m_db = New NotesDatabase("", "")
m_db.OpenMail
strForm = "Memo"
Else
Set m_db = session.CurrentDatabase
If dtype = DISPLAYTYPE_DIALOG Then strForm = "DialogReport" Else strForm = "Report"
End If
If formName <> "" Then strForm = formName
If strBodyItem = "" Then strBodyItem = "Body"
If Not (existingDoc Is Nothing) Then
Set m_docReport = existingDoc
' we assume the caller will remove the rich text field if they didn't want to append to it.
Dim rti As Variant
Set rti = m_docReport.GetFirstItem(strBodyItem)
If Not (rti Is Nothing) Then
If rti IsA "NOTESRICHTEXTITEM" Then
Set m_rti = rti
Else
m_docReport.RemoveItem(strBodyItem)
End If
End If
Else
Set m_docReport = m_db.CreateDocument
Call m_docReport.ReplaceItemValue("Form", strForm)
End If
If m_rti Is Nothing Then Set m_rti = m_docReport.CreateRichTextItem(strBodyItem)
WindowTitle = "Please assign WindowTitle property"
End Sub

Sub Delete
If AutoDisplay Then Display
End Sub

Public Property Get Document( ) As NotesDocument
' Caller is requesting document containing the report output. First, finish all pending changes.
' Useful if, for instance, you wanted to mail the report rather than displaying it on screen.
Flush True
m_rti.Update ' make sure the document they're requesting is all up to date
Set document = m_docReport
End Property

Public Property Get RtItem( ) As NotesRichTextItem
Flush True
m_rti.Update
Set RTItem = m_rti
End Property

Function AddTable(ByVal rows%, rti1 As NotesRichTextItem, rti2 As NotesRichTextItem) As NotesRichTextTable
Flush True
m_rti.AppendRTItem rti1 ' that's the first table. Do we need more?
m_rti.Update
Set m_rtnavTable = m_rti.CreateNavigator
Set AddTable = m_rtnavTable.GetLastElement(RTELEM_TYPE_TABLE)
Dim toAdd%, hasRows%
hasRows = AddTable.RowCount
If hasRows < rows Then
' there aren't as many rows as were requested. How many more can we add to the current table?
If rows < 256 Then toAdd = rows-hasRows Else toAdd = 255-hasRows
AddTable.AddRow(toAdd)
rows = rows - hasRows - toAdd
While rows > 0
' we need even more rows. Load up a second table.
m_rti.AppendRTItem rti2
Dim otherTable As NotesRichTextTable
Set otherTable = m_rtnavTable.GetLastElement(RTELEM_TYPE_TABLE)
hasRows = otherTable.RowCount
If hasRows < rows Then
If rows > 254 Then toAdd = 254-hasRows Else toAdd = rows-hasRows
otherTable.AddRow toAdd
rows = rows - hasRows - toAdd
ElseIf rows < hasRows Then
otherTable.RemoveRow rows-hasRows
End If
Wend
m_rtnavTable.SetPosition AddTable ' so when we go seek cells we'll start with the first table.
ElseIf rows > 0 And hasRows > rows Then
' table contains more rows than requested; delete the extras from the end.
AddTable.RemoveRow rows-hasRows
End If
End Function

Function AddTableFromPage(ByVal rows%, ByVal FirstPageName$, ByVal ContinuationPageName$) As NotesRichTextTable
' Since the ability of LotusScript to create tables from "scratch" is rather limited,
' this routine lets you specify the name of a Page design element that contains your model
' table (and a second Page element containing the "continuation" table in case of more rows
' than will fit in a single table (255). A similar function could support tables from a
' profile document, for better configurability.
If Not (m_rtnavTable Is Nothing) Then
Error ERR_RGEN_NESTEDTABLE, ERR_RGEN_NESTEDTABLE_TEXT
End If

' Read in the table from the page design element and see how big it is.
Dim ncoll As NotesNoteCollection
Set ncoll = m_db.CreateNoteCollection(False)
Dim rtiTable1 As NotesRichTextItem, rtiTable2 As NotesRichTextItem
ncoll.SelectPages = True
ncoll.SelectionFormula = { $TITLE *= "} & FirstPageName & {"}
If rows > 255 Then ' we also need the continuation table
ncoll.SelectionFormula = ncoll.SelectionFormula & { : "} & ContinuationPageName & {"}
End If
ncoll.BuildCollection
Dim strID$, title
Dim docPage1 As NotesDocument, docPage2 As NotesDocument
strID = ncoll.GetFirstNoteId()
Do Until strID = ""
Dim docPage As NotesDocument
Set docPage = m_db.GetDocumentByID(strID)
title = docPage.GetItemValue("$TITLE")
If Not IsNull(ArrayGetIndex(title, FirstPageName, 1)) Then
Set docPage1 = docPage
Set rtiTable1 = docPage1.GetFirstItem("$BODY")
End If
If Not IsNull(ArrayGetIndex(title, ContinuationPageName, 1)) Then
Set docPage2 = docPage
Set rtiTable2 = docPage2.GetFirstItem("$BODY")
End If
strID = ncoll.GetNextNoteId(strID)
Loop

Set AddTableFromPage = AddTable(rows, rtiTable1, rtiTable2)
End Function

Private Sub EndInsert
If m_bInserting Then
Flush True
m_rti.EndInsert
m_bInserting = False
m_extraChars = 0
End If
End Sub

Sub AdvanceCell(ByVal ctr%)
' advance to the next cell and begin inserting data there.
EndInsert
If m_rtnavTable.FindNextElement(RTELEM_TYPE_TABLECELL, ctr) Then
m_rti.BeginInsert m_rtnavTable
m_bInserting = True
m_extraChars = 0 ' as we have moved to a new cell, there are no chars on the current line.
End If
End Sub

Sub NextCell()
AdvanceCell 1
End Sub

Sub CloseTable()
EndInsert
If Not (m_rtnavTable Is Nothing) Then
Delete m_rtnavTable
End If
End Sub

Sub AddReportTitle(ByVal strTitle$, ByVal strSubtitle$)
AddParagraphStyle RGENpstyleCenter
AddStyle RGENstyleTitle
AddText strTitle
If strSubtitle <> "" Then
AddStyle RGENstyleSubtitle
AddLine strSubtitle, False
End If
AddParagraphStyle RGENpstyleLeft
AddStyle RGENstyleNormal
End Sub

Sub AddNewLine( ByVal count As Integer, ByVal boolParBreak As Boolean)
If boolParBreak Then
Flush True
Call m_rti.AddNewline(count, True)
m_extraChars = 0
Else
Call AddText(String(count, NEWLINE))
End If
End Sub

Sub AddLine(ByVal strLine$, ByVal boolParBreak As Boolean)
' start a new line in the report and begin it with the text we are given.
' if boolParBreak is True, we start a new paragraph first.
If m_started Then
If boolParBreak Then
AddNewLine 1, True
AddText strLine
Else
AddText NEWLINE & strLine
End If
Else
AddText strLine
End If
End Sub

Sub AddText(ByVal strText$)
' Add a block of text to the report. If the text contains linefeeds,
' we'll evaluate the paragraph length so far, to determine whether they can
' be line breaks or have to be changed to paragraph breaks.
m_started = True
m_buffer = m_buffer & strText
If m_extraChars + Len(m_buffer) > PARLIMIT Then
Flush False
End If
End Sub

Sub Flush(boolAll As Boolean)
' When we receive characters, it could happen that we don't know yet whether to output
' them into the rich text item. E.g. say we get <5000 chars><newline><4000 chars>.
' If the next thing we get is <9000 chars>, we'll wish we had put a paragraph break for
' that newline; if the next thing is <newline>, we could use a line break for the first
' newline. So, we buffer the characters until we decide what to do with the newlines.
' Call this function when we have to commit ourselves and actually output some chars.
' If boolAll is True, the _entire_ buffer is output (because we're about to add a style,
' for instance). But we keep track of the number of characters already output in the
' current paragraph. If boolAll is False, we only dump characters until the buffer is
' small enough to put all the rest on one paragraph.
Dim boolDone As Boolean
Do
If m_extraChars + Len(m_buffer) > PARLIMIT Then
' find the last newline that's within the length limit.
Dim pos1 As Long, pos2 As Long
pos1 = InStr(m_buffer, NEWLINE)
pos2 = 0
Do Until pos1 = 0 Or pos1 > PARLIMIT-m_extraChars
pos2 = pos1
pos1 = InStr(pos2+1, m_buffer, NEWLINE)
Loop
If pos1 = 0 And pos2 = 0 Then Error ERR_RGEN_LONGLINE, ERR_RGEN_LONGLINE_TEXT
' pos2 is the position of the last newline we can include within the length limit.
WriteText Left$(m_buffer, pos2-1)
Call m_rti.AddNewline(1, True)
m_extraChars = 0
m_buffer = Mid$(m_buffer, pos2+1) ' discard the text we just output.
Else
boolDone = True
If boolAll And Len(m_buffer) Then
WriteText m_buffer
m_extraChars = m_extraChars + Len(m_buffer)
m_buffer = ""
End If
End If
Loop Until boolDone
End Sub

%REM
Sub WriteText
Description: Workaround for SPR AGUD7UCK38: can't send a huge piece of text to AppendText
%END REM
Private Sub WriteText(x$)
Dim i As Long
For i = 1 To Len(x) Step CHUNKSIZE
Call m_rti.AppendText(Mid$(x, i, CHUNKSIZE))
Next
End Sub

Sub AddStyle(style As NotesRichTextStyle)
Flush True ' dump buffer before add style, or it will apply to wrong text
m_rti.AppendStyle style
End Sub

Sub AddParagraphStyle(pstyle As NotesRichTextParagraphStyle)
Flush True
m_rti.AppendParagraphStyle pstyle
m_extraChars = 0 ' because that started a new paragraph.
m_started = False ' a call to AddLine now doesn't need to insert a line feed.
End Sub

Sub AddLink(linkTo As Variant, ByVal comment As String, ByVal linkText As String)
Flush True ' output all pending plain text.
Call m_rti.AppendDocLink(linkTo, comment, linkText)
End Sub

Sub AddPageBreak(newPStyle As NotesRichTextParagraphStyle)
' argument may be Nothing if you don't want to start a new par style with the new page.
Flush True
If newPStyle Is Nothing Then
Call m_rti.AddPageBreak
Else
Call m_rti.AddPageBreak(newPStyle)
End If
End Sub

Sub Update()
Flush True
m_rti.Update
End Sub

Sub Display( )
' show the report on screen.
If m_displayed Then Exit Sub
m_displayed = True
If m_displaytype = DISPLAYTYPE_QUIET Then Exit Sub
Dim strTitleTemp
Dim wksp As New NotesUIWorkspace
CloseTable ' in case we were populating a table
Flush True
m_rti.Update
If WindowTitle = "" Then strTitleTemp = "<WindowTitle not specified>" Else strTitleTemp = WindowTitle
Select Case m_displaytype
Case DISPLAYTYPE_MSGBOX
MsgBox m_rti.GetFormattedText(False, 32000)
Case DISPLAYTYPE_DIALOG
Call wksp.DialogBox(m_docReport.GetItemValue("Form")(0), False, False, True, True, True, True, strTitleTemp, m_docReport, False, True)
Case DISPLAYTYPE_MEMO
Call m_docReport.ReplaceItemValue("Subject", WindowTitle)
Call wksp.EditDocument(True, m_docReport, True, , False)
Case Else
m_docReport.WindowTitle = strTitleTemp
Call wksp.EditDocument(False, m_docReport, True, , False)
End Select
End Sub

End Class
'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
Dim session As New NotesSession
Set RGENstyleTitle = session.CreateRichTextStyle
Set RGENstyleSubtitle = session.CreateRichTextStyle
Set RGENstyleHeader = session.CreateRichTextStyle
Set RGENstyleNormal = session.CreateRichTextStyle
Set RGENstyleEmphasis = session.CreateRichTextStyle
Set RGENstyleError = session.CreateRichTextStyle
Set RGENstyleFixed = session.CreateRichTextStyle
Set RGENpstyleCenter = session.Createrichtextparagraphstyle
Set RGENpstyleLeft = session.Createrichtextparagraphstyle
Set RGENpstyleIndent = session.Createrichtextparagraphstyle

With RGENstyleTitle
.Bold = True
.Italic = False
.FontSize = 18
.NotesColor = COLOR_DARK_BLUE
.NotesFont = FONT_ROMAN
End With

With RGENstyleSubtitle
.Bold = True
.Italic = False
.FontSize = 14
.NotesColor = COLOR_DARK_BLUE
.NotesFont = FONT_ROMAN
End With

With RGENstyleHeader
.Bold = True
.Italic = True
.FontSize = 12
.NotesColor = COLOR_DARK_RED
.NotesFont = FONT_HELV
End With

With RGENstyleNormal
.Bold = False
.Italic = False
.FontSize = 10
.NotesColor = COLOR_BLACK
.NotesFont = FONT_HELV
End With

With RGENstyleEmphasis
.Bold = True
.Italic = False
.FontSize = 10
.NotesColor = COLOR_BLACK
.NotesFont = FONT_HELV
End With

With RGENstyleError
.Bold = True
.Italic = False
.FontSize = 10
.NotesColor = COLOR_RED
.NotesFont = FONT_HELV
End With

With RGENstyleFixed
.Bold = False
.Italic = False
.FontSize = 10
.NotesColor = COLOR_BLACK
.NotesFont = FONT_COURIER
End With

RGENpstyleLeft.Alignment = ALIGN_LEFT
RGENpstyleCenter.Alignment = ALIGN_CENTER
RGENpstyleIndent.Alignment = ALIGN_LEFT
RGENpstyleIndent.LeftMargin = RULER_ONE_INCH * 1.5
RGENpstyleIndent.FirstLineLeftMargin = RGENpstyleIndent.LeftMargin
End Sub









'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright 2009 IBM Corporation

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

Library Class RTDataTable
Created Jun 23, 2009 by Andre Guirard/Cambridge/IBM
Description: This library supports the reading of data from a table in a rich text
field. The table might have a header row listing the column names. The values
read are returned in generic "Record" records from which the caller can either
read by column name, or numeric index.
%END REM
Option Public
Option Declare


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class RTDataTable
Declare Class RTDRecord

'++LotusScript Development Environment:2:5:(Declarations):0:10

Const ERR_RTD_NO_TABLE = 17860 ' there was no table in the rich text field.
Const ERR_RTD_MISMATCH = 17861 ' the table doesn't contain the number of columns you specified.

Private Const NL = {
}

%REM
Class RTDataTable
Description: Comments for Class
%END REM
Class RTDataTable
m_first As RTDRecord
m_last As RTDRecord
m_current As RTDRecord
m_col As Integer ' index of next column.
m_cCols As Integer ' number of columns
m_cellContent As String ' text so far in current cell
m_inited As Boolean
m_inCell As Boolean ' whether the SAX parser is inside a tablecell element
m_inPar As Boolean ' whether we've seen a <par> since the beginning of the tablecell.
m_rows As Long ' how many rows of data.

Public Indexes List As Integer ' key is column name, value is array index
Public Fieldnames As String ' if blank, read from table.
Public SkipFirstRow As Boolean ' set True if the table contains a title row that you want to skip.

%REM
Property Get Rows
Description: Return number of rows in the table (after Load is called).
%END REM
Public Property Get Rows As Long
Rows = m_rows
End Property

Private Sub SAX_Characters( Source As NotesSAXParser, ByVal Characters As String, ByVal Length As Long )
If m_inPar Then
m_cellContent = m_cellContent & Characters
End If
End Sub

Private Sub SAX_EndElement( Source As NotesSAXParser, ByVal ElementName As String )
Select Case elementName
Case "tablerow"
If m_inited Then
If Not m_current Is Nothing Then
me.Append m_current
Set m_current = Nothing
End If
If m_col <> m_cCols Then
Error ERR_RTD_MISMATCH, "Number of columns (" & m_col & ") doesn't match number of fieldnames (" & m_cCols & ")."
End if
Else
m_inited = True ' the next row will be read as data
m_cCols = m_col
End If
m_col = 0
Case "tablecell"
m_inCell = False
m_inPar = False
' cell content is now complete. What to do with it?
If m_inited Then
m_current.SetString m_col, m_cellContent
Else
' cell contains fieldname.
m_cellContent = LCase(FullTrim(Replace(m_cellContent, Split(NL & ";,;" & Chr$(9), ";"), Split(";;", ";"))))
If m_col = 1 Then fieldnames = m_cellContent Else fieldnames = fieldnames & "," & m_cellContent
Indexes(m_cellContent) = m_col
End If
m_cellContent = ""
End Select
End Sub

%REM
Sub SAX_StartElement
Description: Process the beginning of an XML element.
%END REM
Private Sub SAX_StartElement( Source As NotesSAXParser, ByVal ElementName As String, Attributes As NotesSAXAttributeList )
Select Case elementName
Case "tablerow"
m_col = 0
If m_inited Then
Set m_current = New RTDRecord(Me, m_cCols)
Else
' todo
End If
Case "tablecell"
m_col = m_col + 1
m_inCell = True
Case "par"
If m_inCell Then
If m_inPar Then ' the first par in a cell just represents the start of the text
m_cellContent = m_cellContent & NL
Else ' subsequent pars represent line breaks
m_inPar = true
End If
End If
Case "break"
If m_inCell Then m_cellContent = m_cellContent & NL
End Select
End Sub

%REM
Sub Load
Description: Comments for Sub
%END REM
Sub Load(docPro As NotesDocument, itemName$)
Dim session As New NotesSession
Dim dxle As NotesDXLExporter
Dim stream As NotesStream
Dim saxp As NotesSAXParser
Dim docExp As NotesDocument

If docPro.Hasitem("$Name") Then ' profile doc doesn't export sensibly
Set docExp = docPro.Parentdatabase.Createdocument
docPro.Copyallitems docExp, true
docPro.Removeitem "$Name"
Else
Set docExp = docPro
End If
Set stream = session.Createstream
Set dxle = session.Createdxlexporter(docExp, stream)
dxle.Restricttoitemnames = itemName
Set saxp = session.Createsaxparser(stream)
On Event SAX_Characters From saxp Call SAX_Characters
On Event SAX_EndElement From saxp Call SAX_EndElement
On Event SAX_StartElement From saxp Call SAX_StartElement

Dim fnames
If Len(Fieldnames) Then
fnames = FullTrim(Split(fieldnames, ","))
m_cCols = UBound(fnames)+1
Dim i%
For i = 1 To m_cCols
Indexes(fnames(i-1)) = i
Next
m_inited = true
End if
dxle.Process
saxp.Process
Exit sub
'Error ERR_RTD_NO_TABLE, "There is no table in the rich text field. //RTDataTable.Load"
End Sub

%REM
Property First
Description: Retrieve the first record of table data.
%END REM
Public Property Get First As RTDRecord
Set First = m_first
End Property

Private Sub Append(rec As RTDRecord)
If m_first Is Nothing Then
Set m_first = rec
Else
Set m_last.Next = rec
End If
Set m_last = rec
m_rows = m_rows + 1
End Sub

%REM
Sub Delete
Description: Aggressively delete the list... LotusScript sometimes doesn't handle it all.
%END REM
Sub Delete
Dim node As RTDRecord
Do Until m_first Is Nothing
Set node = m_First
Delete m_first
Set m_first = node
Loop
End Sub
End Class

%REM
Class RTDRecord
Description: Represents one row from the data table.
%END REM
Class RTDRecord
data() As String
Public Next As RTDRecord
parent As RTDataTable

%REM
Sub New
Description: Internal use only.
%END REM
Sub New(parent As RTDataTable, ByVal cols%)
Dim i%
ReDim data(1 To cols)
Set me.parent = parent
End Sub

%REM
Function index
Description: Convert a column name to the corresponding array index.
If given a number, it's already an array index so return the number.
%END REM
Private Function index(ind)
If DataType(ind) = 8 Then
index = parent.Indexes(LCase(ind))
Else
index = ind
End If
End Function

%REM
Sub SetString
Description: Internal method, do not use.
%END REM
Sub SetString(ind, value$)
data(index(ind)) = value
End Sub

%REM
Function GetString
Description: Return the text read from the column whose name or index is 'ind'.
e.g. rtr.GetString("Price")
%END REM
Function GetString(ind) As String
On Error GoTo oops
GetString = data(index(ind))
Exit Function
oops:
Error Err, Error & " //RTDataTable.GetString(" & ind & ")"
End Function

%REM
Function GetNumber
Description: Read the value from a column with a given name or index,
assuming the value is numeric. The value 'def' is the default value
to return if the column is blank.
You could do the same with Cdbl(rtr.GetString(ind)).
%END REM
Function GetNumber(ind, ByVal def%) As Double
Dim tmp As String
tmp = data(index(ind))
If Len(tmp) Then GetNumber = CDbl(tmp) Else GetNumber = def
End Function

%REM
Function GetList
Description: Read the value from a column if the column contains
a list value. Returns an array of the values found. The arguments
are the column name or index, 'ind', and 'delims', a string containing
one or more alternate delimiters, e.g. ",;" if list items might be
delimited by either comma or semicolon.
Using FullTrim on the return value to eliminate blank entries and
excess whitespace, is advised.
%END REM
Function GetList(ind, delims$) As Variant
Dim tmp As String, res, adelim$, i%
tmp = data(index(ind))
GetList = Split(tmp, Left$(delims, 1))
For i = 2 To Len(delims)
adelim = Mid$(delims, i, 1)
GetList = Split(Join(GetList, adelim), adelim)
Next
End Function
End Class
'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library StringDiff v1.1
Created Jul 8, 2009 by Andre Guirard/Cambridge/IBM
Description: Supports finding the differences between two strings (which might be
entire files, or the text from rich text items).
%END REM
Option Public
Option Declare

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Private Class CQueueNode
Declare Private Class Cqueue
Declare Class StringDiffer
Declare Class DiffResultNode
Declare Class DiffWriter
Declare Class DiffWriterRT As DiffWriter
Declare Class DiffWriterHTML As DiffWriter
Declare Class DiffWriterSideBySide As DiffWriterHTML
Declare Class DiffResult
Declare Private Function WhitespaceNear(strVal$, ByVal pos As Long, ByVal range As Long) As Long
Declare Private Function ToHTML(strText$) As String

'++LotusScript Development Environment:2:5:(Declarations):0:10

Const WHITESPACEMATCH = {*[
]*}
Const WORDBREAKMATCH = {[
,."+:;*!?/=\)(|{}}]}

%REM
Class CQueueNode
Description: Data node for a linked list to be used in a queue.
%END REM
Private Class CQueueNode
Public Val As Variant
Public Next As CQueueNode

Sub New(valu, nextNode As CQueueNode)
Set Me.val = valu
Set Me.next = nextNode
End Sub
End Class

%REM
Class Cqueue
Description: Simple implementation of a queue using linked lists.
%END REM
Private Class Cqueue
first As CQueueNode

Sub push(x)
Set first = New CQueueNode(x, first)
End Sub

Function pop()
If first Is Nothing Then
Set pop = Nothing
Else
Set pop = first.val
Set first = first.next
End If
End Function
End Class
%REM
Class StringDiffer
Description: Utility class to compare strings and return a list of their
differences, in the form of alternating "same" and "different" nodes.
The "same" nodes contain one string; the "different" nodes contain two.
%END REM
Class StringDiffer
qWork As Cqueue

Sub New
Set qWork = New Cqueue
End Sub

%REM
Function FindDifferences
Description: Returns the first node in a linked list of objects describing the
portions of two strings that are the same or different.
%END REM
Function FindDifferences(str1$, str2$) As DiffResult
Dim bWords As Boolean

' figure out whether we're comparing a piece of text containing words,
' vs an alphanumeric value where we want to highlight internal character differences.
' E.g. in a piece of text, we want to say they changed "hapen" to "happened", not that
' they added a p and an ed. But if the values were "2983ST298393" and "2983ST2958393",
' it's more useful to show where a 5 was added.
If str1 Like WHITESPACEMATCH Then
bWords = True
ElseIf Not str1 Like {*[!-a-zA-Z']*} Then
bWords = True
ElseIf str2 Like WHITESPACEMATCH Then
bWords = True
ElseIf Not str2 Like {*[!-a-zA-Z']*} Then
bWords = True
End If

Dim current As DiffResultNode, first As DiffResultNode
Set current = New DiffResultNode(Nothing, False)
Set first = current
current.setDiff str1, str2
Do Until current Is Nothing
Process current, bWords
' if processing current node generated more "difference" nodes, drill down into those.
Set current = qWork.pop()
Loop

' find the new first node
Do Until first.prev Is Nothing
Set first = first.prev
Loop

' a special case occurs if we get strings with no differences.
' We'll have a SAME node, then a DIFFERENT node with "" as both values.
If first.isSame Then
Set current = first.Next
If Not (current Is Nothing) Then
If Len(current.val1) + Len(current.val2) = 0 Then
Set first.next = current.next
Delete current
End If
End If
End If
Set FindDifferences = New DiffResult
Set FindDifferences.First = First
End Function

Private Function FindCommonEnd(str1$, str2$, ByVal pos1 As Long, ByVal pos2 As Long, _
ByVal maxMatch As Long) As Long
' ending before position pos1 in str1, and position pos2 in str2, find out how many characters are
' the same starting from those spots. The answer will not be more than maxMatch.
Dim worstcase As Long
Dim curlen As Long
If pos1-maxMatch <= 0 Then maxMatch = pos1-1
If pos2-maxMatch <= 0 Then maxMatch = pos2-1
If maxMatch = 0 Then Exit Function ' returning 0

Do
curlen = (1+maxMatch+worstcase) \ 2
If Mid$(str1, pos1-curlen, curlen) = Mid$(str2, pos2-curlen, curlen) Then
worstcase = curlen
Else
maxMatch = curLen-1
End If
Loop Until maxMatch <= worstcase
FindCommonEnd = worstcase
End Function

Private Function FindCommonStart(str1$, str2$, ByVal pos1 As Long, ByVal pos2 As Long, _
ByVal maxMatch As Long) As Long
' ending before position pos1 in str1, and position pos2 in str2, find out how many characters are
' the same starting from those spots. The answer will not be more than maxMatch.
Dim worstcase As Long
Dim curlen As Long
If pos1+maxMatch > Len(str1) Then maxMatch = Len(str1) - pos1 + 1
If pos2+maxMatch > Len(str2) Then maxMatch = Len(str2) - pos2 + 1
If maxMatch <= 0 Then Exit Function ' returning 0

Dim plen As Long
Do
curlen = (1+maxMatch+worstcase) \ 2
If Mid$(str1, pos1, curlen) = Mid$(str2, pos2, curlen) Then
worstcase = curlen
Else
maxMatch = curLen-1
End If
Loop Until maxMatch <= worstcase
FindCommonStart = worstcase
End Function

Private Sub lcs(str1$, str2$, lBegin1 As Long, lBegin2 As Long, lLen As Long, ByVal bWords As Boolean)
' find the longest common substring of two strings.
If Len(str1) > Len(str2) Then
Call lcs(str2, str1, lBegin2, lBegin1, lLen, bWords)
Else
' now we can proceed on the assumption that str2 is the longer one
Dim bestPos1 As Long, bestPos2 As Long, bestLen As Long
Dim curLen As Long, curPos As Long, maxLen As Long
Dim addlBefore As Long, addlAfter As Long, pos2 As Long
Dim bestPossible As Long

pos2 = InStr(str2, str1)
If pos2 Then
lbegin1 = 1
lbegin2 = pos2
lLen = Len(str1)
Exit Sub
End If

maxLen = Len(str1)
curLen = maxLen\2
bestPossible = maxlen
If maxlen > 400 Then bestLen = 40 Else bestlen = maxlen \ 10 ' if the matching section is less than 1/10th the string it's probably a fluke.

Do While curLen > 0 And bestLen < bestpossible
For curPos = 1 To maxLen Step curLen
' break the shorter string up into blocks of curLen chars.
' The longest matching string we could miss detecting on this pass is curLen*2-2 chars;
' any longer than that, and it would have to entirely contain one of the blocks.
pos2 = 0
Dim strTmp$
strTmp = Mid$(str1, curPos, curLen)
Do
pos2 = InStr(pos2+1, str2, strTmp)
If pos2 = 0 Then Exit Do

If bestpos2 Then If pos2 >= bestpos2 And pos2 < bestpos2 + bestlen Then GoTo nextmatch
' we already know about this matching segment.

' we have matched curLen chars!
' how many chars before this one substring might also match? If there were more than
' curlen-1, we would've caught it on the previous iteration of the For loop.
addlBefore = FindCommonEnd(str1, str2, curpos, pos2, curLen-1)
' what about after this substring? We know bestpossible is the most we can expect
' to match, so bestpossible less whatever we already matched.
addlAfter = FindCommonStart(str1, str2, curpos+curLen, pos2+curLen, bestpossible-curLen-addlBefore)
Dim lLent As Long, lStart1 As Long, lStart2 As Long
lLEnt = addlBefore+Len(strTmp)+addlAfter
If lLent <= bestLen Then GoTo nextmatch
lStart1 = curPos - addlBefore
lStart2 = pos2 - addlBefore
If bWords Then
' we don't want to find differences within words. Even if characters match, ignore the matching chars
' at the beginning and end if they're not preceded by a word break.
Dim ws1 As Boolean

' if the first character in the matching part is not whitespace, we
' have to do more. We have to find out whether the character preceding the
' first char is whitespace (or it is the first char) in BOTH strings.
' If not, trim chars from the start of the matching string until it starts
' with whitespace.
If Not (Mid$(str1, lStart1, 1) Like WORDBREAKMATCH) then
If lstart1 = 1 Then ws1 = True Else ws1 = (Mid$(str1, lStart1-1, 1) Like WORDBREAKMATCH)
If ws1 Then
If lstart2 = 1 Then ws1 = True Else ws1 = (Mid$(str2, lStart2-1, 1) Like WORDBREAKMATCH)
End if
If Not ws1 then
' the matching strings start in the middle of a word. Back up until
' they start with whitespace.
Do Until lLent <= bestLen
lStart1 = lStart1 + 1
lStart2 = lStart2 + 1
lLent = lLent - 1
If Mid$(str2, lStart2, 1) Like WORDBREAKMATCH Then Exit Do
Loop
End if
End If

If lLent <= bestLen Then GoTo nextmatch
' ditto, if the last char in the matching part is not whitespace,
' check the character following that in each string to see whether
' it's a non-whitespace char.
Dim lEnd1 As Long
lEnd1 = lStart1 + lLent-1 ' pos of last char in 1st match string.
If Not (Mid$(str1, lEnd1, 1) Like WORDBREAKMATCH) Then
If lEnd1 = Len(str1) Then ws1 = True Else ws1 = (Mid$(str1, lEnd1+1, 1) Like WORDBREAKMATCH)
If ws1 Then
If lStart2 + lLent > Len(str2) Then
ws1 = True
Else
ws1 = (Mid$(str2, lStart2 + lLent, 1) Like WORDBREAKMATCH)
End if
End If
If Not ws1 Then
' we're in the middle of a word. Trim chars off end until the last char is whitespace
Do
lEnd1 = lEnd1 - 1
lLent = lLent - 1
If lLent <= bestlen Then Exit do
Loop Until Mid$(str1, lEnd1, 1) Like WORDBREAKMATCH
End If
End If
End If ' bWords

If lLent > bestLen Then
bestLen = lLent
bestPos1 = lStart1
bestPos2 = lStart2
End If
nextmatch:
Loop ' while pos2 > 0
Next
bestpossible = (curlen*2)-2 ' the greatest matching string length we might possibly have missed on this iteration.
curLen = (1+curLen)\2
Loop

lBegin1 = bestPos1
lBegin2 = bestPos2
If bestPos1 Then lLen = bestLen Else lLen = 0
End If
End Sub


%REM
Sub Process
Description: Take a "different" node and look for portions of the strings
that are identical, creating "same" nodes out of them, until
there are no more identical parts.
%END REM
Private Sub Process(node As DiffResultNode, ByVal bWords As Boolean)
Dim lBegin1 As Long, lBegin2 As Long, lLen As Long
Do
If Len(node.val1) = 0 Then Exit Sub
If Len(node.val2) = 0 Then Exit Sub
Call lcs(node.val1, node.val2, lBegin1, lBegin2, llen, bWords)
If llen Then
splitnode node, lBegin1, lBegin2, llen
Else
Exit Sub
End If
Loop
End Sub

%REM
Sub splitnode
Description: Take a "different" node that contains a matching substring in its
two parts, and change that matching part into a "same" node. So at least
one "same" node will be created here; if the matching part is not at the
start or end, a "different" node will be created also to sandwich the "same"
node between two "differents".
%END REM
Private Sub splitnode(node As DiffResultNode, begin1 As Long, begin2 As Long, length As Long)
Dim newSameNode As DiffResultNode

If begin1 = 1 And begin2 = 1 Then
' The beginning part is the matching part, to insert a same node in front.
Set newSameNode = New DiffResultNode(node, False)
newSameNode.setsame Left$(node.val1, length)
node.val1 = Mid$(node.val1, length+1)
node.val2 = Mid$(node.val2, length+1)
Else ' the matching part is not at the beginning.
Set newSameNode = New DiffResultNode(node, True)
newSameNode.setSame Mid$(node.val1, begin1, length)
If begin1+length <= Len(node.val1) Or begin2+length <= Len(node.val2) Then
' the matching part is not at the end either, so there's a new difference
' node to follow the same node.
Dim newDiffNode As New DiffResultNode(newSameNode, True)
newDiffNode.setDiff Mid$(node.val1, begin1+length), Mid$(node.val2, begin2+length)
qWork.push newDiffNode
End If
node.val1 = Left$(node.val1, begin1-1)
node.val2 = Left$(node.val2, begin2-1)
End If
End Sub

End Class
%REM
Class DiffResultNode
Description: Nodes of a linked list of results of a diff tool.
%END REM
Class DiffResultNode
Public isSame As Boolean
Public val1 As String
Public val2 As String
Public Next As DiffResultNode
Public prev As DiffResultNode

%REM
Sub New
Description: The insertionpoint is the node that this is added adjacent to,
and bAfter is True if the new node is supposed to follow the insertion point,
False to precede it.
%END REM
Sub New(insertionpoint As DiffResultNode, ByVal bAfter As Boolean)
If insertionpoint Is Nothing Then
Set Me.next = Nothing
Set Me.prev = Nothing
ElseIf bAfter Then
Set Me.prev = insertionpoint
Set Me.next = insertionpoint.next
If Not (Me.next Is Nothing) Then
Set Me.next.prev = Me
End If
Set insertionpoint.next = Me
Else
Set Me.next = insertionpoint
Set Me.prev = insertionpoint.prev
If Not (Me.prev Is Nothing) Then
Set Me.prev.next = Me
End If
Set insertionpoint.prev = Me
End If
End Sub

%REM
Sub SetSame
Description: Set this to be a "same" node with the given text.
%END REM
Sub SetSame(szVal$)
IsSame = True
val1 = szVal
End Sub

%REM
Sub EraseChain
Description: An alternative to StringDiffer.Clean -- free all the memory
in the linked list. This is needed because the nodes refer to each other
in a doubly linked list, so their reference counters will never drop
to zero even when the pointer to the first node goes out of scope.
%END REM
Sub EraseChain
Dim tmp As DiffResultNode, tmpNext As DiffResultNode
Set tmp = me.Next
Do Until tmp Is Nothing
Set tmpNext = tmp.Next
Delete tmp
Set tmp = tmpNext
Loop

Set tmp = me.Prev
Do Until tmp Is Nothing
Set tmpNext = tmp.prev
Delete tmp
Set tmp = tmpNext
Loop

End Sub

%REM
Sub SetDiff
Description: Make this a "different" node with the two values given.
%END REM
Sub SetDiff(szVal1$, szVal2$)
IsSame = False
val1 = szVal1
val2 = szVal2
End Sub

End Class

%REM
Class DiffWriter
Description: Once you have the list of differences and same sections, you often will want to
display the results to a user. This base class provides methods to override to produce
the specific type of output you need.
%END REM
Class DiffWriter
Public MaxSegment As Long ' blocks of text longer than this will have a ellipsis in the middle (0 = don't add ellipsis)
Public EllipsisText As String

Sub New
EllipsisText = "@@@" ' easier to see than "..."
End Sub

%REM
Sub WriteNewText
Description: Output an indication that a string was added (it was in string2 but not string1).
%END REM
Private Sub WriteNewText(strNewText$)
End Sub

%REM
Sub WriteDeletedText
Description: Output an indication that text was removed from string1.
%END REM
Private Sub WriteDeletedText(strDeleted$)
End Sub

%REM
Sub WriteSameText
Description: Output a stretch of text that was the same in both strings.
%END REM
Private Sub WriteSameText(strSame$)
End Sub

%REM
Sub WriteModified
Description: Indicate that a section was changed between the two strings.
%END REM
Private Sub WriteModified(szOld$, szNew$)
WriteDeletedText szOld
WriteNewText szNew
End Sub

%REM
Sub PutText
Description: Write text into the output (lower-level routine called by the
various "write" functions.
%END REM
Private Sub PutText(strText$)
End Sub

%REM
Sub WriteText
Description: Insert ellipsis if needed, and write given text to the output.
It's assumed that styling, HTML tags or whatever have already been output
that will make this text appear correctly for whatever you're doing.
%END REM
Private Sub WriteText(strText$)
If MaxSegment Then
If Len(strText) > MaxSegment Then
PutText Left$(strText, MaxSegment/2 - 2)
WriteEllipsis
PutText Right$(strText, MaxSegment/2 - 2)
Exit Sub
End If
End If
PutText strText
End Sub

%REM
Sub WriteEllipsis
Description: Output an indication that characters were omitted here.
%END REM
Private Sub WriteEllipsis
End Sub

%REM
Sub WriteDiffs
Description: Scan the list of nodes and call the appropriate other routines to
generate the desired output.
%END REM
Sub WriteDiffs(diffs As DiffResult)
Dim firstNode As DiffResultNode
Dim node As DiffResultNode
Set firstNode = diffs.First
Set node = firstNode
Begin
Do Until node Is Nothing
If node.isSame Then
If Len(node.val1) Then
WriteSameText node.val1
End If
Else
If Len(node.val1) Then
If Len(node.val2) Then
WriteModified node.val1, node.val2
Else
WriteDeletedText node.val1
End If
ElseIf Len(node.val2) Then
WriteNewText node.val2
End If
End If
Set node = node.Next
Loop
Finish
End Sub

%REM
Sub Finish
Description: Routine called automatically when output generation is finished.
%END REM
Private Sub Finish
End Sub

%REM
Sub Begin
Description: Called automatically before start of output generation.
%END REM
Private Sub Begin
End Sub
End Class

%REM
Class DiffWriterRT
Description: The "rich text" version of the DiffWriter uses rich text styles to
indicate what's been added, deleted, modified.
%END REM
Class DiffWriterRT As DiffWriter
Public styleNew As NotesRichTextStyle ' style for text that was added.
Public styleDel As NotesRichTextStyle ' text that was deleted
Public styleNormal As NotesRichTextStyle ' that that's the same in the compared strings
Public styleEllipsis As NotesRichTextStyle ' the "..." you might choose to insert in long blocks.

Private m_curStyle As NotesRichTextStyle
m_rti As NotesRichTextItem

%REM
Sub new
Description: Pass in the rich text item into which you would like the results written.
%END REM
Sub New(rti As NotesRichTextItem)
Set m_rti = rti
Dim session As New NotesSession
Set styleNew = session.Createrichtextstyle
styleNew.Bold = True
styleNew.Notescolor = COLOR_RED
styleNew.Strikethrough = False

Set styleDel = session.Createrichtextstyle
styleDel.Bold = True
styleDel.Strikethrough = True
styleDel.Notescolor = COLOR_BLUE

Set styleNormal = session.Createrichtextstyle
styleNormal.Bold = False
styleNormal.Strikethrough = False
styleNormal.Notescolor = COLOR_BLACK

Set styleEllipsis = session.Createrichtextstyle
styleEllipsis.Bold = False
styleEllipsis.Strikethrough = False
styleEllipsis.Notescolor = COLOR_MAGENTA
End Sub

%REM
Sub WriteStyledText
Description: Output a style followed by some text. Remember which
style was used so that if we have to interrupt it with ellipsis,
we know how to resume the style after the ellipsis.
%END REM
Private Sub WriteStyledText(style As NotesRichTextStyle, strDat$)
Set m_curStyle = style
m_rti.Appendstyle style
WriteText strDat
End Sub

%REM
Sub WriteNewText
Description: See base class.
%END REM
Private Sub WriteNewText(strNewText$)
WriteStyledText styleNew, strNewText
End Sub

%REM
Sub WriteDeletedText
Description: See base class.
%END REM
Private Sub WriteDeletedText(strDeleted$)
WriteStyledText styleDel, strDeleted
End Sub

%REM
Sub WriteEllipsis
Description: Write an indication that the text was abridged here.
%END REM
Private Sub WriteEllipsis
m_rti.Appendstyle styleEllipsis
m_rti.Appendtext EllipsisText
m_rti.Appendstyle m_curStyle
End Sub

%REM
Sub WriteSameText
Description: See base class.
%END REM
Private Sub WriteSameText(szText$)
WriteStyledText styleNormal, szText
End Sub

%REM
Sub PutText
Description: Write text to a rich text field; because of a bug registering newlines
if the argument to AppendText is too long, break long strings up into smaller chunks.
%END REM
Private Sub PutText(strText$)
If Len(strText) > 14000 Then
Dim i As Long, tmp$
For i = 1 To Len(strText) Step 14000
tmp = Mid$(strText, i, 14000)
m_rti.Appendtext tmp
Next
Else
m_rti.Appendtext strText
End If
End Sub

%REM
Sub Finish
Description: Called when output generation is complete.
%END REM
Private Sub Finish
m_rti.Update
End Sub
End Class




%REM
Class DiffWriterHTML
Description: Generate HTML output of a string difference list, using HTML elements
presumed to be defined in the stylesheet (they have no meaning in regular HTML).
%END REM
Class DiffWriterHTML As DiffWriter
m_result As NotesStream

Public NewTag As String ' lets you control what's output around "new" text.
Public DelTag As String
Public EllipsisTag As String

%REM
Sub New
Description: You may pass in your own stream (if you want output to a file, for instance)
or pass Nothing and a stream will be generated for you.
%END REM
Sub New(stream As NotesStream)
If stream Is Nothing Then
Dim session As New NotesSession
Set m_result = session.CreateStream
Else
Set m_result = stream
End If
NewTag = "new"
DelTag = "strike"
EllipsisTag = "ellipsis"
End Sub

%REM
Property Get Stream
Description: The stream containing the output. Note the Position will not be at zero.
%END REM
Public Property Get Stream As NotesStream
Set stream = m_result
End Property

%REM
Property Get HTML
Description: The text version of the output. If you passed the constructor a stream,
this will include any characters that were in the stream originally.
%END REM
Public Property Get HTML
m_result.Position = 0
HTML = m_result.Readtext
End Property

%REM
Sub WriteNewText
Description: Write text inside a <new> element.
%END REM
Private Sub WriteNewText(strNewText$)
m_result.Writetext {<} & NewTag & {>}
WriteText strNewText
m_result.Writetext {</} & StrToken(NewTag, " ", 1) & {>}
End Sub

%REM
Sub WriteDeletedText
Description: Write text inside a <strike> element.
%END REM
Private Sub WriteDeletedText(strDeleted$)
m_result.Writetext {<} & DelTag & {>}
WriteText strDeleted
m_result.Writetext {</} & StrToken(DelTag, " ", 1) & {>}
End Sub

%REM
Sub WriteSameText
Description: Just write the "plain" text.
%END REM
Private Sub WriteSameText(strSame$)
WriteText strSame
End Sub

%REM
Sub PutText
Description: When putting text at the lowest level, convert to HTML chars.
%END REM
Private Sub PutText(strText$)
m_result.Writetext ToHTML(strText)
End Sub

%REM
Sub WriteEllipsis
Description: Write an indication that characters were omitted at this point.
%END REM
Private Sub WriteEllipsis
m_result.Writetext "<" & EllipsisTag & ">" & EllipsisText & "</" & StrToken(EllipsisTag, " ", 1) & ">"
End Sub
End Class

%REM
Class DiffWriterSideBySide
Description: A variant of the HTML writer that creates an HTML table showing the diffs.
In this case the New and Del elements are replaced with arguments to the TD tag.
%END REM
Class DiffWriterSideBySide As DiffWriterHTML
Public EmptyTag As String

Sub New(stream As NotesStream), DiffWriterHTML(stream)
NewTag = {bgcolor="#C0FFC0"}
DelTag = {bgcolor="#FFC0C0"}
EmptyTag = {bgcolor="#C0C0C0"}
End Sub

%REM
Sub Begin
Description: Called automatically before starting to output node data.
%END REM
Private Sub Begin
m_result.Writetext {<table width="100%" border="0"><tr><td width="50%" align="center"><em>OLD</em></td><td width="50%" align="center"><em>NEW</em></td>}
End Sub

%REM
Sub Finish
Description: Called automatically when the writing is done.
%END REM
Private Sub Finish
m_result.Writetext {</table>}
End Sub

%REM
Sub WriteNewText
Description: New text is displayed on the right, with a blank cell on the left.
%END REM
Private Sub WriteNewText(szText$)
m_result.Writetext {<tr><td } & EmptyTag & {></td><td } & NewTag & {>}
WriteText szText
m_result.Writetext {</td></tr>}
End Sub

%REM
Sub WriteDeletedText
Description: Deleted text is displayed on the left, with a blank cell on the right.
%END REM
Private Sub WriteDeletedText(szText$)
m_result.Writetext {<tr><td } & DelTag & {>}
WriteText szText
m_result.Writetext {</td><td bgcolor="#C0C0C0"></td></tr>}
End Sub

%REM
Sub WriteModified
Description: Modified text is displayed with the original on the left and the
new text on the right.
%END REM
Private Sub WriteModified(sz1$, sz2$)
m_result.Writetext {<tr><td bgcolor="#FFC0C0">}
Writetext sz1
m_result.Writetext {</td><td bgcolor="#C0FFC0">}
Writetext sz2
m_result.Writetext {</td></tr>}
End Sub

%REM
Sub WriteSame
Description: Text that's the same between the two sides is displayed in a merged row.
%END REM
Private Sub WriteSameText(szText$)
m_result.Writetext {<tr><td colspan="2">}
WriteText szText
m_result.Writetext {<td></tr>}
End Sub
End Class
%REM
Class DiffResult
Description: Contains the result of a string comparison.
%END REM
Class DiffResult
Public First As DiffResultNode

%REM
Property Get Same
Description: Returns True if the strings compared were identical.
%END REM
Public Property Get Same As Boolean
Same = First.Next Is Nothing And first.isSame
End Property

Sub Delete
First.EraseChain
End Sub
End Class
'++LotusScript Development Environment:2:1:WhitespaceNear:12:8
%REM
Function WhitespaceNear
Description: Locate the nearest whitespace character to a given position in a
string, either before or after,
Parameters:
- strval: the string to search
- pos: starting position for search
- range: number of characters before and after to search.
Returns: position of whitespace character. If none found in the given
range, returns pos.
%END REM
Private Function WhitespaceNear(strVal$, ByVal pos As Long, ByVal range As Long) As Long
If Not (Mid$(strVal, pos, 1) Like WORDBREAKMATCH) Then
Dim ssign As Long, li As Long, newpos As Long
For li = 1 To range
For ssign = -li To li Step (li+li)
newpos = pos + ssign
If Mid$(strVal, newpos, 1) Like WORDBREAKMATCH Then
WhitespaceNear = newpos
Exit Function
End If
Next
Next
End If
WhitespaceNear = pos
End Function


'++LotusScript Development Environment:2:1:ToHTML:6:8
%REM
Function ToHTML
Description: Escape special characters in the input string to
produce an HTML representation of the string.
%END REM
Private Function ToHTML(strText$) As String
Static ffrom() As String, tto() As String
On Error GoTo arrayinit
tryagain:
ToHTML = Replace(strText, ffrom, tto)
Exit Function
arrayinit:
ReDim ffrom(0 To 4)
ReDim tto(0 To 4)
ffrom(0) = {&}
ffrom(1) = {>}
ffrom(2) = {<}
ffrom(3) = {"}
ffrom(4) = {
}
tto(0) = {&amp;}
tto(1) = {&gt;}
tto(2) = {&lt;}
tto(3) = {&quot;}
tto(4) = {<br>}
GoTo tryAgain
End Function




























'++LotusScript Development Environment:2:5:(Options):0:74
%REM
Copyright IBM Corp. 2010

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library StringDiffMB v1.1
Description: Supports finding the differences between two strings (which might be
entire files, or the text from rich text items), including determining whether
chunks of text have been moved around.
- Created Jul 8, 2009 by Andre Guirard/Cambridge/IBM
- 9 Oct 09, Andre Guirard added moved block detection, fixed bug.
%END REM
Option Public
Option Declare

'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Private Class CQueueNode
Declare Private Class Cqueue
Declare Class StringDiffer
Declare Class DiffResultNode
Declare Class DiffWriter
Declare Class DiffWriterRT As DiffWriter
Declare Class DiffWriterHTML As DiffWriter
Declare Class DiffWriterSideBySide As DiffWriterHTML
Declare Class DiffResult
Declare Class BlockNode
Declare Private Class BlockNodeColl
Declare Private Function WhitespaceNear(strVal$, ByVal pos As Long, ByVal range As Long) As Long
Declare Private Function ToHTML(strText$) As String

'++LotusScript Development Environment:2:5:(Declarations):0:10

Const WHITESPACEMATCH = {*[
]*}
Const WORDBREAKMATCH = {[
,."+:;*!?/=\)(|{}}]}
Const D_SAME = 1
const D_DIFF = 0
Const D_MOVEDTO = 2
Const D_MOVEDFROM = 3

%REM
Class CQueueNode
Description: Data node for a linked list to be used in a queue.
%END REM
Private Class CQueueNode
Public Val As Variant
Public Next As CQueueNode

Sub New(valu, nextNode As CQueueNode)
Set Me.val = valu
Set Me.next = nextNode
End Sub
End Class


%REM
Class Cqueue
Description: Simple implementation of a queue using linked lists.
%END REM
Private Class Cqueue
first As CQueueNode

Sub push(x)
Set first = New CQueueNode(x, first)
End Sub

Function pop()
If first Is Nothing Then
Set pop = Nothing
Else
Set pop = first.val
Set first = first.next
End If
End Function
End Class
%REM
Class StringDiffer
Description: Utility class to compare strings and return a list of their
differences, in the form of alternating "same" and "different" nodes.
The "same" nodes contain one string; the "different" nodes contain two.
%END REM
Class StringDiffer
m_qWork As Cqueue
m_MovedBlockLimit As Integer

%REM
Sub New
Description: if movedBlock argument is > 0, moved-block detection is turned on,
allowing you to distinguish between text that's new vs. has merely been moved around.
The number is the minimum size of block you want to bother considering as moved,
so if not zero, it should be at least 15.
%END REM
Sub New(ByVal movedBlock As Integer)
Set m_qWork = New Cqueue
m_MovedBlockLimit = movedBlock
End Sub

%REM
Sub PunctuationToFollow
Description: If a difference node is followed by punctuation, and begins with the same punctuation,
shift it to the preceding same node.
%END REM
Private Sub PunctuationToFollow(first As DiffResultNode)
Dim rec As DiffResultNode, foll As DiffResultNode
Set rec = first.next
Do Until rec Is Nothing
Set foll = rec.next
If rec.type = D_DIFF Then
If (foll Is Nothing) Then Exit do
If foll.type = D_SAME Then
Do
Dim ch1$
ch1 = Left(foll.val1, 1)
If Not ch1 Like WORDBREAKMATCH Then Exit Do
If ch1 <> Left$(rec.val1, 1) And Len(rec.val1) Then Exit Do
If ch1 <> Left$(rec.val2, 1) And Len(rec.val2) Then Exit Do
' shift the different section one char right.
rec.prev.val1 = rec.prev.val1 & ch1
foll.val1 = Mid$(foll.val1, 2)
If Len(rec.val1) Then rec.val1 = Mid$(rec.val1, 2) & ch1
If Len(rec.val2) Then rec.val2 = Mid$(rec.val2, 2) & ch1
Loop
If Len(foll.val1) = 0 Then ' same section empty! merge two "diff" nodes & discard "same" node.
Dim tmp As DiffResultNode
Set tmp = foll.Next
Delete foll
If not (tmp Is Nothing) Then
' merge two diff nodes
rec.val1 = rec.val1 & tmp.val1
rec.val2 = rec.val2 & tmp.val2
Set foll = tmp.Next
Set rec.next = foll
If foll Is Nothing Then Exit Do
Set foll.prev = rec
End If
End If
End If
End If
Set rec = foll
Loop
End Sub

%REM
Function FindDifferences
Description: Returns the first node in a linked list of objects describing the
portions of two strings that are the same or different.
%END REM
Function FindDifferences(str1$, str2$) As DiffResult
Dim bWords As Boolean

' figure out whether we're comparing a piece of text containing words,
' vs an alphanumeric value where we want to highlight internal character differences.
' E.g. in a piece of text, we want to say they changed "hapen" to "happened", not that
' they added a p and an ed. But if the values were "2983ST298393" and "2983ST2958393",
' it's more useful to show where a 5 was added.
If str1 Like WHITESPACEMATCH Then
bWords = True
ElseIf Not str1 Like {*[!-a-zA-Z']*} Then
bWords = True
ElseIf str2 Like WHITESPACEMATCH Then
bWords = True
ElseIf Not str2 Like {*[!-a-zA-Z']*} Then
bWords = True
End If

Dim current As DiffResultNode, first As DiffResultNode
Set current = New DiffResultNode(Nothing, False)
Set first = current
current.setDiff str1, str2
Do Until current Is Nothing
Process current, bWords
' if processing current node generated more "difference" nodes, drill down into those.
Set current = m_qWork.pop()
Loop

' find the new first node
Do Until first.prev Is Nothing
Set first = first.prev
Loop

' a special case occurs if we get strings with no differences.
' We'll have a SAME node, then a DIFFERENT node with "" as both values.
If first.type = D_SAME Then
Set current = first.Next
If Not (current Is Nothing) Then
If Len(current.val1) + Len(current.val2) = 0 Then
Set first.next = current.next
Delete current
End If
End If
End If

If bWords Then
PunctuationToFollow first

If m_MovedBlockLimit Then
MovedBlockCheck first
Do Until first.prev Is Nothing
Set first = first.prev
Loop
End If
End If

Set FindDifferences = New DiffResult
Set FindDifferences.First = First
End Function

%REM
Sub ProcessMoveCheck
Description: check one node to see whether it is the source of some text that was moved
to another node. The source node is assumed to be of the DIFF type.
%END REM
Private Sub ProcessMoveCheck(bc As BlockNodeColl, first As DiffResultNode, source As DiffResultNode)
Dim tn As DiffResultNode
Set tn = first
Do Until tn Is Nothing
If Not (tn Is source) Then
If tn.type = D_DIFF Then
If Len(tn.val2) >= m_MovedBlockLimit Then
Dim Lbegin1 As Long, Lbegin2 As Long, Llen As Long
lcs source.val1, tn.val2, lbegin1, lbegin2, llen, true
If llen >= m_movedBlockLimit Then
Dim mbn As New BlockNode
Set mbn.fromnode = source
Set mbn.tonode = tn
mbn.len = llen
mbn.frompos = Lbegin1
mbn.topos = Lbegin2
bc.Insert mbn
End If
End If
End If
End If
Set tn = tn.Next
Loop
End Sub

%REM
Sub MovedBlockCheck
Description: After the initial scan, look for parts of the text that have just been moved around.
%END REM
Private Sub MovedBlockCheck(first As DiffResultNode)
Dim bc As New BlockNodeColl, fn As DiffResultNode, tn As DiffResultNode, mbn As BlockNode
Set fn = first
Do Until fn Is Nothing
If fn.type = D_DIFF Then
If Len(fn.val1) >= m_MovedBlockLimit Then
ProcessMoveCheck bc, first, fn
End If
End If
Set fn = fn.Next
Loop

Do Until bc.first Is Nothing
Set mbn = bc.first
' take the largest moved block we detected as a new "moved" node.
Dim newNode As DiffResultNode
Dim strBef$, strAft$
Set fn = mbn.fromnode
Set tn = mbn.tonode
If mbn.frompos > 1 Then
Set newNode = New DiffResultNode(fn, False)
newNode.SetDiff Left$(fn.val1, mbn.frompos-1), fn.val2
m_qWork.push newNode ' check this for moved blocks too...
End If
If mbn.frompos+mbn.Len <= Len(fn.val1) Then
Set newNode = New DiffResultNode(fn, True)
newNode.SetDiff Mid$(fn.val1, mbn.frompos+mbn.Len), ""
m_qWork.push newNode ' check this for moved blocks too...
End If
fn.val1 = Mid$(fn.val1, mbn.frompos, mbn.Len)
fn.type = D_MOVEDFROM

If mbn.topos > 1 Then
Set newNode = New DiffResultNode(tn, False)
newNode.SetDiff tn.val1, Left$(tn.val2, mbn.topos-1)
m_qWork.push newNode ' check this for moved blocks too...
End If
If mbn.topos+mbn.Len <= Len(tn.val2) Then
Set newNode = New DiffResultNode(tn, True)
newNode.SetDiff "", Mid$(tn.val2, mbn.topos+mbn.Len)
End If
tn.val2 = Mid$(tn.val2, mbn.topos, mbn.Len)
tn.type = D_MOVEDTO
bc.retireFirst
Set fn = m_qWork.pop
Do Until fn Is Nothing
If Len(fn.val1) >= m_MovedBlockLimit Then
ProcessMoveCheck bc, first, fn
End If
Set fn = m_qWork.pop
Loop
Loop
End Sub

Private Function FindCommonEnd(str1$, str2$, ByVal pos1 As Long, ByVal pos2 As Long, _
ByVal maxMatch As Long) As Long
' ending before position pos1 in str1, and position pos2 in str2, find out how many characters are
' the same starting from those spots. The answer will not be more than maxMatch.
Dim worstcase As Long
Dim curlen As Long
If pos1-maxMatch <= 0 Then maxMatch = pos1-1
If pos2-maxMatch <= 0 Then maxMatch = pos2-1
If maxMatch = 0 Then Exit Function ' returning 0

Do
curlen = (1+maxMatch+worstcase) \ 2
If Mid$(str1, pos1-curlen, curlen) = Mid$(str2, pos2-curlen, curlen) Then
worstcase = curlen
Else
maxMatch = curLen-1
End If
Loop Until maxMatch <= worstcase
FindCommonEnd = worstcase
End Function

Private Function FindCommonStart(str1$, str2$, ByVal pos1 As Long, ByVal pos2 As Long, _
ByVal maxMatch As Long) As Long
' ending before position pos1 in str1, and position pos2 in str2, find out how many characters are
' the same starting from those spots. The answer will not be more than maxMatch.
Dim worstcase As Long
Dim curlen As Long
If pos1+maxMatch > Len(str1) Then maxMatch = Len(str1) - pos1 + 1
If pos2+maxMatch > Len(str2) Then maxMatch = Len(str2) - pos2 + 1
If maxMatch <= 0 Then Exit Function ' returning 0

Dim plen As Long
Do
curlen = (1+maxMatch+worstcase) \ 2
If Mid$(str1, pos1, curlen) = Mid$(str2, pos2, curlen) Then
worstcase = curlen
Else
maxMatch = curLen-1
End If
Loop Until maxMatch <= worstcase
FindCommonStart = worstcase
End Function

Private Sub lcs(str1$, str2$, lBegin1 As Long, lBegin2 As Long, lLen As Long, ByVal bWords As Boolean)
' find the longest common substring of two strings.
If Len(str1) > Len(str2) Then
Call lcs(str2, str1, lBegin2, lBegin1, lLen, bWords)
Else
' now we can proceed on the assumption that str2 is the longer one
Dim bestPos1 As Long, bestPos2 As Long, bestLen As Long
Dim curLen As Long, curPos As Long, maxLen As Long
Dim addlBefore As Long, addlAfter As Long, pos2 As Long
Dim bestPossible As Long

pos2 = InStr(str2, str1)
If pos2 Then
lbegin1 = 1
lbegin2 = pos2
lLen = Len(str1)
Exit Sub
End If

maxLen = Len(str1)
curLen = maxLen\2
bestPossible = maxlen
If maxlen > 400 Then bestLen = 40 Else bestlen = maxlen \ 10 ' if the matching section is less than 1/10th the string it's probably a fluke.

Do While curLen > 0 And bestLen < bestpossible
For curPos = 1 To maxLen Step curLen
' break the shorter string up into blocks of curLen chars.
' The longest matching string we could miss detecting on this pass is curLen*2-2 chars;
' any longer than that, and it would have to entirely contain one of the blocks.
pos2 = 0
Dim strTmp$
strTmp = Mid$(str1, curPos, curLen)
Do
pos2 = InStr(pos2+1, str2, strTmp)
If pos2 = 0 Then Exit Do

If bestpos2 Then If pos2 >= bestpos2 And pos2 < bestpos2 + bestlen Then GoTo nextmatch
' we already know about this matching segment.

' we have matched curLen chars!
' how many chars before this one substring might also match? If there were more than
' curlen-1, we would've caught it on the previous iteration of the For loop.
addlBefore = FindCommonEnd(str1, str2, curpos, pos2, curLen-1)
' what about after this substring? We know bestpossible is the most we can expect
' to match, so bestpossible less whatever we already matched.
addlAfter = FindCommonStart(str1, str2, curpos+curLen, pos2+curLen, bestpossible-curLen-addlBefore)
Dim lLent As Long, lStart1 As Long, lStart2 As Long
lLEnt = addlBefore+Len(strTmp)+addlAfter
If lLent <= bestLen Then GoTo nextmatch
lStart1 = curPos - addlBefore
lStart2 = pos2 - addlBefore
If bWords Then
' we don't want to find differences within words. Even if characters match, ignore the matching chars
' at the beginning and end if they're not preceded by a word break.
Dim ws1 As Boolean

' if the first character in the matching part is not whitespace, we
' have to do more. We have to find out whether the character preceding the
' first char is whitespace (or it is the first char) in BOTH strings.
' If not, trim chars from the start of the matching string until it starts
' with whitespace.
If Not (Mid$(str1, lStart1, 1) Like WORDBREAKMATCH) then
If lstart1 = 1 Then ws1 = True Else ws1 = (Mid$(str1, lStart1-1, 1) Like WORDBREAKMATCH)
If ws1 Then
If lstart2 = 1 Then ws1 = True Else ws1 = (Mid$(str2, lStart2-1, 1) Like WORDBREAKMATCH)
End if
If Not ws1 then
' the matching strings start in the middle of a word. Back up until
' they start with whitespace.
Do Until lLent <= bestLen
lStart1 = lStart1 + 1
lStart2 = lStart2 + 1
lLent = lLent - 1
If Mid$(str2, lStart2, 1) Like WORDBREAKMATCH Then Exit Do
Loop
End if
End If

If lLent <= bestLen Then GoTo nextmatch
' ditto, if the last char in the matching part is not whitespace,
' check the character following that in each string to see whether
' it's a non-whitespace char.
Dim lEnd1 As Long
lEnd1 = lStart1 + lLent-1 ' pos of last char in 1st match string.
If Not (Mid$(str1, lEnd1, 1) Like WORDBREAKMATCH) Then
If lEnd1 = Len(str1) Then ws1 = True Else ws1 = (Mid$(str1, lEnd1+1, 1) Like WORDBREAKMATCH)
If ws1 Then
If lStart2 + lLent > Len(str2) Then
ws1 = True
Else
ws1 = (Mid$(str2, lStart2 + lLent, 1) Like WORDBREAKMATCH)
End if
End If
If Not ws1 Then
' we're in the middle of a word. Trim chars off end until the last char is whitespace
Do
lEnd1 = lEnd1 - 1
lLent = lLent - 1
If lLent <= bestlen Then Exit do
Loop Until Mid$(str1, lEnd1, 1) Like WORDBREAKMATCH
End If
End If
End If ' bWords

If lLent > bestLen Then
bestLen = lLent
bestPos1 = lStart1
bestPos2 = lStart2
End If
nextmatch:
Loop ' while pos2 > 0
Next
bestpossible = (curlen*2)-2 ' the greatest matching string length we might possibly have missed on this iteration.
curLen = (1+curLen)\2
Loop

lBegin1 = bestPos1
lBegin2 = bestPos2
If bestPos1 Then lLen = bestLen Else lLen = 0
End If
End Sub


%REM
Sub Process
Description: Take a "different" node and look for portions of the strings
that are identical, creating "same" nodes out of them, until
there are no more identical parts.
%END REM
Private Sub Process(node As DiffResultNode, ByVal bWords As Boolean)
Dim lBegin1 As Long, lBegin2 As Long, lLen As Long
Do
If Len(node.val1) = 0 Then Exit Sub
If Len(node.val2) = 0 Then Exit Sub
Call lcs(node.val1, node.val2, lBegin1, lBegin2, llen, bWords)
If llen Then
splitnode node, lBegin1, lBegin2, llen
Else
Exit Sub
End If
Loop
End Sub

%REM
Sub splitnode
Description: Take a "different" node that contains a matching substring in its
two parts, and change that matching part into a "same" node. So at least
one "same" node will be created here; if the matching part is not at the
start or end, a "different" node will be created also to sandwich the "same"
node between two "differents".
%END REM
Private Sub splitnode(node As DiffResultNode, begin1 As Long, begin2 As Long, length As Long)
Dim newSameNode As DiffResultNode

If begin1 = 1 And begin2 = 1 Then
' The beginning part is the matching part, to insert a same node in front.
Set newSameNode = New DiffResultNode(node, False)
newSameNode.setsame Left$(node.val1, length)
node.val1 = Mid$(node.val1, length+1)
node.val2 = Mid$(node.val2, length+1)
Else ' the matching part is not at the beginning.
Set newSameNode = New DiffResultNode(node, True)
newSameNode.setSame Mid$(node.val1, begin1, length)
If begin1+length <= Len(node.val1) Or begin2+length <= Len(node.val2) Then
' the matching part is not at the end either, so there's a new difference
' node to follow the same node.
Dim newDiffNode As New DiffResultNode(newSameNode, True)
newDiffNode.setDiff Mid$(node.val1, begin1+length), Mid$(node.val2, begin2+length)
m_qWork.push newDiffNode
End If
node.val1 = Left$(node.val1, begin1-1)
node.val2 = Left$(node.val2, begin2-1)
End If
End Sub

End Class
%REM
Class DiffResultNode
Description: Nodes of a linked list of results of a diff tool.
%END REM
Class DiffResultNode
Public type As Integer
Public val1 As String
Public val2 As String
Public Next As DiffResultNode
Public prev As DiffResultNode

%REM
Sub New (internal use)
Description: The insertionpoint is the node that this is added adjacent to,
and bAfter is True if the new node is supposed to follow the insertion point,
False to precede it.
%END REM
Sub New(insertionpoint As DiffResultNode, ByVal bAfter As Boolean)
If insertionpoint Is Nothing Then
Set Me.next = Nothing
Set Me.prev = Nothing
ElseIf bAfter Then
Set Me.prev = insertionpoint
Set Me.next = insertionpoint.next
If Not (Me.next Is Nothing) Then
Set Me.next.prev = Me
End If
Set insertionpoint.next = Me
Else
Set Me.next = insertionpoint
Set Me.prev = insertionpoint.prev
If Not (Me.prev Is Nothing) Then
Set Me.prev.next = Me
End If
Set insertionpoint.prev = Me
End If
End Sub

%REM
Sub SetSame (internal use)
Description: Set this to be a "same" node with the given text.
%END REM
Sub SetSame(szVal$)
me.type = D_SAME
val1 = szVal
End Sub

%REM
Sub EraseChain (internal use)
Description: An alternative to StringDiffer.Clean -- free all the memory
in the linked list. This is needed because the nodes refer to each other
in a doubly linked list, so their reference counters will never drop
to zero even when the pointer to the first node goes out of scope.
%END REM
Sub EraseChain
Dim tmp As DiffResultNode, tmpNext As DiffResultNode
Set tmp = me.Next
Do Until tmp Is Nothing
Set tmpNext = tmp.Next
Delete tmp
Set tmp = tmpNext
Loop

Set tmp = me.Prev
Do Until tmp Is Nothing
Set tmpNext = tmp.prev
Delete tmp
Set tmp = tmpNext
Loop

End Sub

%REM
Sub SetDiff
Description: Make this a "different" node with the two values given.
%END REM
Sub SetDiff(szVal1$, szVal2$)
me.type = D_DIFF
val1 = szVal1
val2 = szVal2
End Sub

End Class

%REM
Class DiffWriter
Description: Once you have the list of differences and same sections, you often will want to
display the results to a user. This base class provides methods to override to produce
the specific type of output you need.
%END REM
Class DiffWriter
Public MaxSegment As Long ' blocks of text longer than this will have a ellipsis in the middle (0 = don't add ellipsis)
Public EllipsisText As String

Sub New
EllipsisText = "@@@" ' easier to see than "..."
End Sub

%REM
Sub WriteNewText
Description: Output an indication that a string was added (it was in string2 but not string1).
%END REM
Private Sub WriteNewText(strNewText$)
End Sub

%REM
Sub WriteDeletedText
Description: Output an indication that text was removed from string1.
%END REM
Private Sub WriteDeletedText(strDeleted$)
End Sub

%REM
Sub WriteMovedFrom
Description: Output an indication that text was moved from here to somewhere else.
%END REM
Private Sub WriteMovedFrom(strMoved$)
WriteDeletedText strMoved
End Sub

%REM
Sub WriteMovedTo
Description: Output an indication that text was moved to here from elsewhere.
%END REM
Private Sub WriteMovedTo(strMoved$)
WriteNewText strMoved
End Sub

%REM
Sub WriteSameText
Description: Output a stretch of text that was the same in both strings.
%END REM
Private Sub WriteSameText(strSame$)
End Sub

%REM
Sub WriteModified
Description: Indicate that a section was changed between the two strings.
%END REM
Private Sub WriteModified(szOld$, szNew$)
WriteDeletedText szOld
WriteNewText szNew
End Sub

%REM
Sub PutText
Description: Write text into the output (lower-level routine called by the
various "write" functions.
%END REM
Private Sub PutText(strText$)
End Sub

%REM
Sub WriteText
Description: Insert ellipsis if needed, and write given text to the output.
It's assumed that styling, HTML tags or whatever have already been output
that will make this text appear correctly for whatever you're doing.
%END REM
Private Sub WriteText(strText$)
If MaxSegment Then
If Len(strText) > MaxSegment Then
PutText Left$(strText, MaxSegment/2 - 2)
WriteEllipsis
PutText Right$(strText, MaxSegment/2 - 2)
Exit Sub
End If
End If
PutText strText
End Sub

%REM
Sub WriteEllipsis
Description: Output an indication that characters were omitted here.
%END REM
Private Sub WriteEllipsis
End Sub

%REM
Sub WriteDiffs
Description: Scan the list of nodes and call the appropriate other routines to
generate the desired output.
%END REM
Sub WriteDiffs(diffs As DiffResult)
Dim firstNode As DiffResultNode
Dim node As DiffResultNode
Set firstNode = diffs.First
Set node = firstNode
Begin
Do Until node Is Nothing
If node.type = D_SAME Then
If Len(node.val1) Then
WriteSameText node.val1
End If
ElseIf node.type = D_MOVEDFROM Then
WriteMovedFrom node.val1
ElseIf node.type = D_MOVEDTO Then
WriteMovedTo node.val2
Else
If Len(node.val1) Then
If Len(node.val2) Then
WriteModified node.val1, node.val2
Else
WriteDeletedText node.val1
End If
ElseIf Len(node.val2) Then
WriteNewText node.val2
End If
End If
Set node = node.Next
Loop
Finish
End Sub

%REM
Sub Finish
Description: Routine called automatically when output generation is finished.
%END REM
Private Sub Finish
End Sub

%REM
Sub Begin
Description: Called automatically before start of output generation.
%END REM
Private Sub Begin
End Sub
End Class

%REM
Class DiffWriterRT
Description: The "rich text" version of the DiffWriter uses rich text styles to
indicate what's been added, deleted, modified.
%END REM
Class DiffWriterRT As DiffWriter
Public styleNew As NotesRichTextStyle ' style for text that was added.
Public styleDel As NotesRichTextStyle ' text that was deleted
Public styleNormal As NotesRichTextStyle ' that that's the same in the compared strings
Public styleEllipsis As NotesRichTextStyle ' the "..." you might choose to insert in long blocks.
Public styleMovedFrom As NotesRichTextStyle ' style for text that was cut to elsewhere in the text.
Public styleMovedTo As NotesRichTextStyle ' style for text that was pasted from elsewhere in the text.

Private m_curStyle As NotesRichTextStyle
m_rti As NotesRichTextItem

%REM
Sub new
Description: Pass in the rich text item into which you would like the results written.
%END REM
Sub New(rti As NotesRichTextItem)
Set m_rti = rti
Dim session As New NotesSession
Set styleNew = session.Createrichtextstyle
styleNew.Bold = True
styleNew.Italic = False
styleNew.Notescolor = COLOR_RED
styleNew.Strikethrough = False

Set styleDel = session.Createrichtextstyle
styleDel.Bold = True
styleDel.Italic = False
styleDel.Strikethrough = True
styleDel.Notescolor = COLOR_BLUE

Set styleNormal = session.Createrichtextstyle
styleNormal.Bold = False
styleNormal.Italic = false
styleNormal.Strikethrough = False
styleNormal.Notescolor = COLOR_BLACK

Set styleEllipsis = session.Createrichtextstyle
styleEllipsis.Bold = False
styleEllipsis.Italic = false
styleEllipsis.Strikethrough = False
styleEllipsis.Notescolor = COLOR_MAGENTA

Set styleMovedFrom = session.Createrichtextstyle
styleMovedFrom.Bold = True
styleMovedFrom.Italic = true
styleMovedFrom.Strikethrough = True
styleMovedFrom.Notescolor = COLOR_GRAY

Set styleMovedTo = session.Createrichtextstyle
styleMovedTo.Bold = True
styleMovedTo.Notescolor = COLOR_DARK_GREEN
styleMovedTo.Italic = True
styleMovedTo.Strikethrough = False
End Sub

%REM
Sub WriteStyledText
Description: Output a style followed by some text. Remember which
style was used so that if we have to interrupt it with ellipsis,
we know how to resume the style after the ellipsis.
%END REM
Private Sub WriteStyledText(style As NotesRichTextStyle, strDat$)
Set m_curStyle = style
m_rti.Appendstyle style
WriteText strDat
End Sub

%REM
Sub WriteNewText
Description: See base class.
%END REM
Private Sub WriteNewText(strNewText$)
WriteStyledText styleNew, strNewText
End Sub

%REM
Sub WriteDeletedText
Description: See base class.
%END REM
Private Sub WriteDeletedText(strDeleted$)
WriteStyledText styleDel, strDeleted
End Sub

%REM
Sub WriteEllipsis
Description: Write an indication that the text was abridged here.
%END REM
Private Sub WriteEllipsis
m_rti.Appendstyle styleEllipsis
m_rti.Appendtext EllipsisText
m_rti.Appendstyle m_curStyle
End Sub

%REM
Sub WriteSameText
Description: See base class.
%END REM
Private Sub WriteSameText(szText$)
WriteStyledText styleNormal, szText
End Sub

%REM
Sub WriteMovedFrom
Description: See base class.
%END REM
Private Sub WriteMovedFrom(szText$)
WriteStyledText styleMovedFrom, szText
End Sub

%REM
Sub WriteMovedTo
Description: See base class.
%END REM
Private Sub WriteMovedTo(szText$)
WriteStyledText styleMovedTo, szText
End Sub

%REM
Sub PutText
Description: Write text to a rich text field; because of a bug registering newlines
if the argument to AppendText is too long, break long strings up into smaller chunks.
%END REM
Private Sub PutText(strText$)
If Len(strText) > 14000 Then
Dim i As Long, tmp$
For i = 1 To Len(strText) Step 14000
tmp = Mid$(strText, i, 14000)
m_rti.Appendtext tmp
Next
Else
m_rti.Appendtext strText
End If
End Sub

%REM
Sub Finish
Description: Called when output generation is complete.
%END REM
Private Sub Finish
m_rti.Update
End Sub
End Class




%REM
Class DiffWriterHTML
Description: Generate HTML output of a string difference list, using HTML elements
presumed to be defined in the stylesheet (they have no meaning in regular HTML).
%END REM
Class DiffWriterHTML As DiffWriter
m_result As NotesStream

Public NewTag As String ' lets you control what's output around "new" text.
Public DelTag As String
Public EllipsisTag As String
Public MovedFromTag As String
Public MovedToTag As String

%REM
Sub New
Description: You may pass in your own stream (if you want output to a file, for instance)
or pass Nothing and a stream will be generated for you.
%END REM
Sub New(stream As NotesStream)
If stream Is Nothing Then
Dim session As New NotesSession
Set m_result = session.CreateStream
Else
Set m_result = stream
End If
NewTag = "new"
DelTag = "strike"
EllipsisTag = "ellipsis"
MovedFromTag = "cut"
MovedToTag = "paste"
End Sub

%REM
Property Get Stream
Description: The stream containing the output. Note the Position will not be at zero.
%END REM
Public Property Get Stream As NotesStream
Set stream = m_result
End Property

%REM
Property Get HTML
Description: The text version of the output. If you passed the constructor a stream,
this will include any characters that were in the stream originally.
%END REM
Public Property Get HTML
m_result.Position = 0
HTML = m_result.Readtext
End Property

%REM
Sub WriteNewText
Description: Write text inside a <new> element.
%END REM
Private Sub WriteNewText(strNewText$)
m_result.Writetext {<} & NewTag & {>}
WriteText strNewText
m_result.Writetext {</} & StrToken(NewTag, " ", 1) & {>}
End Sub

%REM
Sub WriteMovedFrom
Description: Output an indication that text was moved from here to somewhere else.
%END REM
Private Sub WriteMovedFrom(strMoved$)
m_result.Writetext {<} & MovedFromTag & {>}
WriteText strMoved
m_result.Writetext {</} & StrToken(MovedFromTag, " ", 1) & {>}
End Sub

%REM
Sub WriteMovedTo
Description: Output an indication that text was moved to here from elsewhere.
%END REM
Private Sub WriteMovedTo(strMoved$)
m_result.Writetext {<} & MovedToTag & {>}
WriteText strMoved
m_result.Writetext {</} & StrToken(MovedToTag, " ", 1) & {>}
End Sub

%REM
Sub WriteDeletedText
Description: Write text inside a <strike> element.
%END REM
Private Sub WriteDeletedText(strDeleted$)
m_result.Writetext {<} & DelTag & {>}
WriteText strDeleted
m_result.Writetext {</} & StrToken(DelTag, " ", 1) & {>}
End Sub

%REM
Sub WriteSameText
Description: Just write the "plain" text.
%END REM
Private Sub WriteSameText(strSame$)
WriteText strSame
End Sub

%REM
Sub PutText
Description: When putting text at the lowest level, convert to HTML chars.
%END REM
Private Sub PutText(strText$)
m_result.Writetext ToHTML(strText)
End Sub

%REM
Sub WriteEllipsis
Description: Write an indication that characters were omitted at this point.
%END REM
Private Sub WriteEllipsis
m_result.Writetext "<" & EllipsisTag & ">" & EllipsisText & "</" & StrToken(EllipsisTag, " ", 1) & ">"
End Sub
End Class

%REM
Class DiffWriterSideBySide
Description: A variant of the HTML writer that creates an HTML table showing the diffs.
In this case the New and Del elements are replaced with arguments to the TD tag.
%END REM
Class DiffWriterSideBySide As DiffWriterHTML
Public EmptyTag As String

Sub New(stream As NotesStream), DiffWriterHTML(stream)
NewTag = {bgcolor="#C0FFC0"}
DelTag = {bgcolor="#FFC0C0"}
EmptyTag = {bgcolor="#C0C0C0"}
End Sub

%REM
Sub Begin
Description: Called automatically before starting to output node data.
%END REM
Private Sub Begin
m_result.Writetext {<table width="100%" border="0"><tr><td width="50%" align="center"><em>OLD</em></td><td width="50%" align="center"><em>NEW</em></td>}
End Sub

%REM
Sub Finish
Description: Called automatically when the writing is done.
%END REM
Private Sub Finish
m_result.Writetext {</table>}
End Sub

%REM
Sub WriteNewText
Description: New text is displayed on the right, with a blank cell on the left.
%END REM
Private Sub WriteNewText(szText$)
m_result.Writetext {<tr><td } & EmptyTag & {></td><td } & NewTag & {>}
WriteText szText
m_result.Writetext {</td></tr>}
End Sub

%REM
Sub WriteMovedTo
Description: Pasted text is displayed on the right, with a text right saying it was moved there.
%END REM
Private Sub WriteMovedTo(szText$)
m_result.Writetext {<tr><td } & EmptyTag & {><em>MOVED HERE</em></td><td } & NewTag & {>}
WriteText szText
m_result.Writetext {</td></tr>}
End Sub

%REM
Sub WriteDeletedText
Description: Deleted text is displayed on the left, with a blank cell on the right.
%END REM
Private Sub WriteDeletedText(szText$)
m_result.Writetext {<tr><td } & DelTag & {>}
WriteText szText
m_result.Writetext {</td><td bgcolor="#C0C0C0"></td></tr>}
End Sub

%REM
Sub WriteMovedFrom
Description: Moved text is displayed on the left, text on right saying it was moved.
%END REM
Private Sub WriteMovedFrom(szText$)
m_result.Writetext {<tr><td } & DelTag & {>}
WriteText szText
m_result.Writetext {</td><td } & EmptyTag & {><em>MOVED BLOCK</em></td></tr>}
End Sub

%REM
Sub WriteModified
Description: Modified text is displayed with the original on the left and the
new text on the right.
%END REM
Private Sub WriteModified(sz1$, sz2$)
m_result.Writetext {<tr><td bgcolor="#FFC0C0">}
Writetext sz1
m_result.Writetext {</td><td bgcolor="#C0FFC0">}
Writetext sz2
m_result.Writetext {</td></tr>}
End Sub

%REM
Sub WriteSame
Description: Text that's the same between the two sides is displayed in a merged row.
%END REM
Private Sub WriteSameText(szText$)
m_result.Writetext {<tr><td colspan="2">}
WriteText szText
m_result.Writetext {<td></tr>}
End Sub
End Class
%REM
Class DiffResult
Description: Contains the result of a string comparison.
%END REM
Class DiffResult
Public First As DiffResultNode

%REM
Property Get Same
Description: Return True if the overall result is that the strings were the same.
%END REM
Public Property Get Same As Boolean
Same = First.Next Is Nothing And first.type = D_SAME
End Property

Sub Delete
First.EraseChain
End Sub
End Class
%REM
Class BlockNode
Description: Nodes describing detected moved block.
%END REM
Class BlockNode
Public fromnode As DiffResultNode
Public frompos As Long
Public tonode As DiffResultNode
Public topos As Long
Public Len As Long
Public Next As BlockNode
End Class


%REM
Class BlockNodeColl
Description: maintains a sorted linked list of BlockNodes, longest first.
Needed for Moved Block detection, to keep track of good candidates to look
for matching portions in.
%END REM
Private Class BlockNodeColl
Public first As BlockNode

Sub insert(mbn As BlockNode)
If first Is Nothing Then
Set first = mbn
ElseIf first.len < mbn.len Then
Set mbn.Next = first
Set first = mbn
Else
Dim cur As BlockNode
Set cur = First
Do Until cur.next Is Nothing
If cur.next.Len < mbn.len Then
Set mbn.Next = cur.Next
Set cur.Next = mbn
Exit sub
End If
Loop
Set cur.next = mbn ' new node goes at end.
End If
End Sub

%REM
Function retireFirst
Description: Delete the current top node and any nodes that are subsumed by that one,
and return the pointer to the next following node.
%END REM
Sub retireFirst
Dim rec As BlockNode, prev As BlockNode
Set rec = first.Next
Set prev = first
Do Until rec Is Nothing
If rec.fromnode Is first.fromnode _
Or rec.fromnode Is first.tonode _
Or rec.tonode Is first.tonode _
Or rec.tonode Is first.fromnode Then
Set prev.next = rec.Next
Delete rec
Set rec = prev.next
Else
Set prev = rec
Set rec = rec.next
End If
Loop
Set rec = first
Set first = first.Next
Delete rec
End Sub
End Class
'++LotusScript Development Environment:2:1:WhitespaceNear:12:8
%REM
Function WhitespaceNear
Description: Locate the nearest whitespace character to a given position in a
string, either before or after,
Parameters:
- strval: the string to search
- pos: starting position for search
- range: number of characters before and after to search.
Returns: position of whitespace character. If none found in the given
range, returns pos.
%END REM
Private Function WhitespaceNear(strVal$, ByVal pos As Long, ByVal range As Long) As Long
If Not (Mid$(strVal, pos, 1) Like WORDBREAKMATCH) Then
Dim ssign As Long, li As Long, newpos As Long
For li = 1 To range
For ssign = -li To li Step (li+li)
newpos = pos + ssign
If Mid$(strVal, newpos, 1) Like WORDBREAKMATCH Then
WhitespaceNear = newpos
Exit Function
End If
Next
Next
End If
WhitespaceNear = pos
End Function


'++LotusScript Development Environment:2:1:ToHTML:6:8
%REM
Function ToHTML
Description: Escape special characters in the input string to
produce an HTML representation of the string.
%END REM
Private Function ToHTML(strText$) As String
Static ffrom() As String, tto() As String
On Error GoTo arrayinit
tryagain:
ToHTML = Replace(strText, ffrom, tto)
Exit Function
arrayinit:
ReDim ffrom(0 To 4)
ReDim tto(0 To 4)
ffrom(0) = {&}
ffrom(1) = {>}
ffrom(2) = {<}
ffrom(3) = {"}
ffrom(4) = {
}
tto(0) = {&amp;}
tto(1) = {&gt;}
tto(2) = {&lt;}
tto(3) = {&quot;}
tto(4) = {<br>}
GoTo tryAgain
End Function





































'++LotusScript Development Environment:2:5:(Options):0:72
%REM
Copyright IBM Corp. 2009

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at:

http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
implied. See the License for the specific language governing
permissions and limitations under the License.

Library TempFolderManager v2.0
Created Aug 19, 2009 by Andre Guirard/Cambridge/IBM
Description: Contains a class to easily create temporary folders and files.
%END REM

Option Public
Option Declare


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class TempFolderManager
Declare Function GetNotesTempDirectory() As String

'++LotusScript Development Environment:2:5:(Declarations):0:10
Declare Function w32_OSGetSystemTempDirectory Lib "nnotes" Alias "OSGetSystemTempDirectory" ( ByVal S As String) As Integer
Declare Function mac_OSGetSystemTempDirectory Lib "NotesLib" Alias "OSGetSystemTempDirectory" ( ByVal S As String) As Integer
Declare Function linux_OSGetSystemTempDirectory Lib "libnotes.so" Alias "OSGetSystemTempDirectory" ( ByVal S As String) As Integer
Const ERR_UNSUPPORTED_PLATFORM = 20300 ' or other value you choose.
%REM
Class TempFolderManager
Description: Create a folder with a unique name as a subdirectory of the Notes temp folder.
When this object is deallocated, delete all the files within the new folder and then
(if that succeeded) delete the folder also.
%END REM
Class TempFolderManager
m_path As String
m_files List As Integer
FolderPrefix As String

%REM
Function Unique
Description: Return a unique string generated by @Unique, minus the username portion.
%END REM
Function Unique As String
Dim unik
unik = Evaluate("@Unique")
Unique = StrToken(unik(0), "-", -1) ' drop the username part of the ID which is always the same for this user
End Function

Sub New(ByVal prefix$)
If Len(prefix) Then FolderPrefix = prefix
m_path = GetNotesTempDirectory & "/" & FolderPrefix & Unique
MkDir m_path
End Sub

%REM
Property Get Path
Description: Returns the path of the temporary folder this class created for you.
%END REM
Public Property Get Path As String
Path = m_path
End Property

%REM
Function CreateFilename
Description: Return the full filepath of a new file that doesn't exist yet.
Arguments suffix is the file suffix, e.g. "html". bManage says that you want
this class to manage the file, i.e. when the object is deallocated, delete
the file also.
%END REM
Function CreateFilename(ByVal strSuffix$, ByVal bManage As Boolean) As String
Dim strFName$
strFName = Unique
If strSuffix <> "" Then strFName = strFName & "." & strSuffix
CreateFilename = m_path & "/" & strFName
If bManage Then
m_files(CreateFilename) = 0
End If
End Function

%REM
Sub Manage
Description: Register this file to be deleted when this object is deallocated.
%END REM
Sub Manage(ByVal strPath$)
m_files(strPath) = 1
End Sub

%REM
Sub Unmanage
Description: Do not delete this file when the object is deallocated.
%END REM
Sub Unmanage(ByVal strPath$)
On Error Resume Next
Erase m_files(strPath)
End Sub

%REM
Function ClearFiles
Description: Erase all files under management but leave the directory so that
we can use it more. Return True if all files were successfully erased.
%END REM
Function ClearFiles( ) As Boolean
On Error GoTo failed
ClearFiles = True
ForAll ffileno In m_files
Kill ListTag(ffileno)
nextFile:
End ForAll
Erase m_files
Exit Function
failed:
ClearFiles = False
Resume nextFile
End Function

Sub Delete
On Error Resume Next
If ClearFiles Then RmDir m_path
End Sub

%REM
Sub CleanupOldFolders
Description: If you've used this class before and created temporary folders,
but then left files behind in them so that the folders could not be deleted,
this routine lets you clean them up. The cutoffAge parameter specifies how
old files and folders have to be, in days, for this routine to clean them
up. A value of 0, of course, will clean up everything. The current temp
folder managed by this class will not be cleaned (see ClearAllFiles for that).
%END REM
Sub CleanupOldFolders(cutoffAge As Double)
Dim szNotesTmp$, szFolder$, szMine$, toKill List As integer
szNotesTmp = StrLeftBack(m_path, "/")
szMine = StrRightBack(m_path, "/")
szFolder = Dir$(szNotesTmp & "/" & FolderPrefix & "??????", 16)
Do While Len(szFolder)
If szFolder <> szMine Then
If Not (Right$(szFolder, 6) Like "*[!2-9A-HJ-NP-Z]*") Then
' matches the pattern of a temp folder name
toKill(szFolder) = 1
End If
End If
szFolder = Dir$
Loop

ForAll folderKey In toKill
Call removeFolderRecursive(szNotesTmp & "/" & ListTag(folderkey), cutoffAge, true)
End ForAll
End Sub

%REM
Function removeFolderRecursive
Description: Remove all contents of a given folder, including the folder if it
winds up being empty, recursively, provided the files are at least cutoffAge
days old. Returns True on success, False if some files or the folder
were not deleted. bDelFolder=true says to delete the folder whose path we're passed.
Otherwise only its contents are deleted (including subfolders).
%END REM
Private Function removeFolderRecursive(ByVal szPath$, ByVal cutoffAge As Double, ByVal bDelFolder As Boolean)
Dim toKill$, szFile$, atts%, szFull$, bKill As Boolean, bKillDir As Boolean, ToKillDir$
removeFolderRecursive = True
On Error GoTo oops
Do
bKillDir = bDelFolder
bDelFolder = True ' after the first time we want to delete folders because they're subfolders
szFile = Dir$(szPath & "/*", 30)
Do While Len(szFile)
If szFile <> "." And szFile <> ".." Then
szFull = szPath & "/" & szFile
atts = GetFileAttr(szFull)
If atts And 16 Then ' a directory
toKill = toKill & szFull & "*"
Else
If cutoffAge <= 0 Then
bKill = True
Else
bKill = (Now - FileDateTime(szFull) >= cutoffAge)
End If

If bKill Then
Kill szFull
Else
bKillDir = False
removeFolderRecursive = False
End If
End If
End If
szFile = Dir$
Loop
If bKillDir Then
' we found no files here we need to keep.
ToKillDir = szPath & "*" & ToKillDir
End If
szPath = StrLeft(toKill, "*")
toKill = Mid$(toKill, Len(szPath) + 2)
Loop While Len(szPath)

Do
szPath = StrLeft(toKillDir, "*")
If szPath = "" Then Exit Function
toKillDir = Mid$(toKillDir, Len(szPath)+2)
RmDir szPath
Loop
Exit Function
oops:
removeFolderRecursive = False
Resume Next
End Function

%REM
Function ClearAllFiles
Description: Remove all files in the temp folder whether we manage them or not.
This also descends into subdirectories.
%END REM
Function ClearAllFiles( ) As Boolean
ClearAllFiles = removeFolderRecursive(m_path, 0, false)
End Function
End Class
'++LotusScript Development Environment:2:1:GetNotesTempDirectory:2:8

Function GetNotesTempDirectory() As String
' Returns the path of the temporary directory used by Notes.
' Not same as system or user temp dir that you can get e.g. with Environ("TEMP") in Windows.
' Main reasons to use this instead: works crossplatform, and partitioned servers each need
' their own temp dir to avoid interfering with each other.
Dim session As New NotesSession
Dim d As String * 256
Dim s%
Select Case session.Platform
Case "Linux"
s% = linux_OSGetSystemTempDirectory(d)
Case "Macintosh"
s% = mac_OSGetSystemTempDirectory(d)
Case "Windows/32"
s% = w32_OSGetSystemTempDirectory(d)
Case Else
Error ERR_UNSUPPORTED_PLATFORM, "In GetNotesTempDirectory, platform not supported: " & session.Platform
End Select
GetNotesTempDirectory = Left$(d, s%)
End Function





'++LotusScript Development Environment:2:5:(Options):0:74
' Copyright 2010 IBM Corporation
'
' Licensed under the Apache License, Version 2.0 (the "License");
' you may not use this file except in compliance with the License.
' You may obtain a copy of the License at
'
' http://www.apache.org/licenses/LICENSE-2.0
'
' Unless required by applicable law or agreed to in writing, software
' distributed under the License is distributed on an "AS IS" BASIS,
' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' See the License for the specific language governing permissions and
' limitations under the License.

%REM
Library UIHelper
Created Mar 9, 2010 by Andre Guirard/Cambridge/IBM
Description: A class with helpful functions to carry out UI operations.
%END REM

Option Public
Option Declare


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Class UIHelper

'++LotusScript Development Environment:2:5:(Declarations):0:10
%REM
Class UIHelper
Description: The UIHelper asks for a database in the constructor to know
where to create temporary in-memory documents and where to look for
helper design elements.
%END REM
Class UIHelper
m_db As NotesDatabase

%REM
Sub New
Description: Database defaults to session.currentdatabase if arg is Nothing
%END REM
Sub New(db_Or_Nothing As NotesDatabase)
Set m_db = db_Or_Nothing
If db_Or_Nothing Is Nothing Then
Dim session As New NotesSession
Set m_db = session.Currentdatabase
End If
End Sub

%REM
Function SaveFilePrompt
Description: Display a "save file" prompt to the user, remembering the
last directory path they used.
Parameters are a subset of those for the NotesUIWorkspace.Savefiledialog method,
i.e. title bar text, file type filters (e.g. "JPG files|*.jpg"), and
initial/default filename.
%END REM
Function SaveFilePrompt(ByVal title$, ByVal filters$, ByVal initialFile$) As String
Dim wksp As New NotesUIWorkspace
Dim session As New NotesSession
Dim docPro As NotesDocument, saveDir$, path, newSaveDir$
Set docPro = m_db.Getprofiledocument("PersonalProfile", session.username)
saveDir = docPro.Getitemvalue("LastPathUsed")(0)
path = wksp.Savefiledialog(False, Title, filters, saveDir, Initialfile)
If IsEmpty(path) Then Exit Function
newSaveDir = path(0)
If InStr(newSaveDir, "\") Then
newSaveDir = StrLeftBack(newSaveDir, "\")
ElseIf InStr(newSaveDir, "/") Then
newSaveDir = StrLeftBack(newSaveDir, "/")
End If
If saveDir <> newSaveDir Then
docPro.lastDir = path(0)
docPro.save True, False, True
End If
SaveFilePrompt = path(0)
End Function

%REM
Function OpenFilePrompt
Description: Use the "open file" dialog in a way that remembers the directory
the user last used while in this application.
Arguments:
multiple: TRUE if the user may select multiple files.
title: text for title bar of dialog.
filters: File filter selection (e.g. "JPG files|*.jpg")
initialFile: If you want to suggest what file the user should open, put its name here.
Returns: EMPTY if no selection made, else an array of filepaths.
%END REM
Function OpenFilePrompt(ByVal multiple As Boolean, ByVal title$, ByVal filters$, ByVal initialFile$)
Dim wksp As New NotesUIWorkspace
Dim session As New NotesSession
Dim docPro As NotesDocument, openDir$, path, newOpenDir$
Set docPro = m_db.Getprofiledocument("PersonalProfile", session.username)
openDir = docPro.Getitemvalue("LastPathUsed")(0)
path = wksp.Openfiledialog(Multiple, Title, Filters, openDir, Initialfile)
If IsEmpty(path) Then Exit Function
newOpenDir = path(0)
If InStr(newOpenDir, "\") Then
newOpenDir = StrLeftBack(newOpenDir, "\")
ElseIf InStr(newOpenDir, "/") Then
newOpenDir = StrLeftBack(newOpenDir, "/")
End If
If openDir <> newOpenDir Then
docPro.lastDir = path(0)
docPro.save True, False, True
End If
OpenFilePrompt = path
End Function

%REM
Function GetColor
Description: Prompt the user to select a color (requires ColorPicker form)
Arguments:
colorName: a descriptive string to appear in the title bar of the dialog.
oldValue: the old color value, in one of three formats:
- eight hex digits (like a 'color field' value, with RGB values at positions 3-8).
- "#" followed by six hex digits (like in a stylesheet)
- six hex digits (2 each R G B)
No color names, please! Case insensitive.
Returns: color value in the same format as oldValue (if oldValue blank,
eight-digits format).
%END REM
Function GetColor(ByVal colorName$, ByVal oldValue$) As String
Dim wksp As New NotesUIWorkspace
Dim docDialog As NotesDocument
Dim bPound As boolean, bSix As Boolean
Set docDialog = m_db.Createdocument
docDialog.Replaceitemvalue "Name", colorName
If Left(oldValue, 1) = "#" Then
oldValue = Mid$(oldValue, 2)
bPound = True
End if
If len(oldValue) = 6 Then
oldvalue = "00" & oldvalue
bSix = true
End If
docDialog.replaceitemvalue "Color", oldValue

Dim ret As Boolean
if wksp.Dialogbox("ColorPicker", true, true, false, false, false, false, "Choose color for " & colorName, _
docDialog, true, false, true) Then
GetColor = docDialog.Getitemvalue("Color")(0)
If bSix Then
GetColor = Mid$(GetColor, 3)
If bPound Then GetColor = "#" + GetColor
End If
End If
End Function

%REM
Function ColorToString
Description: Convert a color value to a 6-digit hex string representation.
%END REM
Function ColorToString(x As NotesColorObject) As String
Dim session As New NotesSession
ColorToString = Right("0" & Hex(x.red), 2) & Right("0" & Hex(x.green), 2) & Right("0" & Hex(x.blue), 2)
End Function

%REM
Function ReorderChoicesDialog
Description: Display a dialog that lets a user reorder a list of strings.
Requires a supporting form or subform named DialogReorderList.
Arguments:
windowTitle: for the title bar of the dialog.
prompt: static text that appears in the dialog
choices: the list of values you would like to rearrange. The output is
written here.
defaultSelection: which value(s), if any, should be selected initially
(may be a string or array of strings).
Return value: TRUE if the user clicked OK in the dialog. If they cancel,
the choices parameter will not be changed.
%END REM
Function ReorderChoicesDialog(ByVal windowTitle$, ByVal prompt$, choices, ByVal defaultSelection ) As Boolean
Dim wksp As New NotesUIWorkspace
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim docDialog As NotesDocument
Set docDialog = db.CreateDocument
docDialog.ReplaceItemValue "SortedList", choices
docDialog.ReplaceItemValue "Prompt", prompt
docDialog.ReplaceItemValue "Selection", defaultSelection
ReorderChoicesDialog = wksp.DialogBox("DialogReorderList", True, True, False, False, False, False, windowTitle, docDialog, True, False, True)
If ReorderChoicesDialog Then choices = docDialog.GetItemValue("SortedList")
End Function
End Class

c:\documents and settings\administrator\desktop\sources\LSGold.ns6
************************************************************************
[Error] - File could not be written...