Description:
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) = {&} tto(1) = {>} tto(2) = {<} tto(3) = {"} 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) = {&} tto(1) = {>} tto(2) = {<} tto(3) = {"} 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...