Bruno Grange
Bruno Grange
"Imagination is more important than knowledge." (Einstein)
Content
Social
| Several @Functions in LotusScript |
 |
 |
| Written by Bruno Grange |
| Wednesday, 03 September 2008 02:24 |
|
Library called @Functions. This library has some usefull @Functions in Lotus Script that we can use on our daily tasks. Some of them have been already implemented in Lotus Notes 6 and 7 Option Public Option Declare ' This library contains LotusScript implementations of the ever-popular macro functions ' @Left, @Right, @Replace, @Trim, @ReplaceSubstring, @Word, @Explode, @Implode, ' @Min, @Max, @Repeat, @Unique, and @Name. ' The implementations are not in all cases complete or exactly identical to the corresponding ' macro functions, but the basic useful functionality of handling lists of values is there. ' Changes for version 1.2: Changed Explode - result is identical but performance is improved ' version 1.3: Fixed Unique function -- wasn't removing some duplicate elements. ' version 1.3: extended Explode to be able to handle multi-character divider strings. ' version 1.5: R5 compatibility - change string length and positions from Integer to Long Const VTRIM_TAB = 1 Const VTRIM_NEWLINE = 2 Const VTRIM_KEEP_NULL = 4 Function Replace1(src As Variant, from_list As Variant, to_list As Variant) As Variant ' Replace in src all occurrences of an item in from_list with the corresponding element of to_list. Dim i% If Isarray(src) Then Redim result(Lbound(src) To Ubound(src)) For i = Lbound(result) To Ubound(result) result(i) = Replace(src(i), from_list, to_list) ' Note: we expect the elements of Replace to be simple strings, but this will also work with an array of arrays. Next Replace1 = result Elseif Isarray(from_list) Then ' The "from" argument is an array; compare each element of the array against the scalar value src. For i = Lbound(from_list) To Ubound(from_list) If src = from_list(i) Then ' If a match is found, get the corresponding element of the "to" list (null string if no corresponding element). If Isarray(to_list) Then If Ubound(to_list) < i Then Replace1 = "" Else Replace1 = to_list(i) End If Elseif i = 0 Then Replace1 = to_list Else Replace1 = "" End If Exit Function End If Next Replace1 = src Elseif from_list = src Then If Isarray(to_list) Then Replace1 = to_list(Lbound(to_list)) Else Replace1 = to_list End If Else Replace1 = src End If End Function Function Count&(s$, k$) Dim p&, r& p = 1 Count = 0 While p>0 r = Instr(p, s$, k$) If r>0 Then Count = Count + 1 p = r + Len(k$) Else p = 0 End If Wend End Function Function Explode(Byval s$, Byval div$) As Variant Redim result(0 To 0) As String Dim i%, pos&, oldpos&, skip& oldpos = 1 skip = Len(div) pos = Instr(s, div) Do Until pos = 0 Redim Preserve result(0 To i+1) result(i) = Mid$(s, oldpos, pos-oldpos) i = i + 1 oldpos = pos + skip pos = Instr(oldpos, s, div) Loop result(i) = Mid$(s, oldpos) Explode = result End Function Function Implode1(s, div As String) As String If Isarray(s) Then Dim i% Implode1 = s(Lbound(s)) For i = Lbound(s)+1 To Ubound(s) Implode1 = Implode1 & div & s(i) Next Else Implode1 = Cstr(s) End If End Function Private Function SingleElementArray(x As Variant) As Variant Dim LittleArray(0 To 0) As Variant LittleArray(0) = x SingleElementArray = LittleArray End Function Function ReplaceSubstring(source As Variant, replace1 As Variant, replacewith As Variant) As Variant ' Written 24 Sept 1996 by Andre Guirard. Dim tTo As Variant, tFrom As Variant Dim i&, j& ' If the search string and replacement are not arrays, make them one element arrays; this makes the ' subsequent code simpler. If Isarray(replace1) Then tFrom = replace1 Else tFrom = SingleElementArray(replace1) End If If Isarray(replacewith) Then tTo = replacewith Else tTo = SingleElementArray(replacewith) End If ' If the main input is an array, recursively process each element and return the results as an array. If Isarray(source) Then Redim result(Lbound(source) To Ubound(source)) As Variant For i = Lbound(source) To Ubound(source) result(i) = ReplaceSubstring(source(i), tFrom, tTo) Next ReplaceSubstring = result Else Dim res$, src$ src$ = source For i = 1 To Len(src$) ' Scan the list of search strings to see whether any of them is present at position i in the source string. For j = Lbound(tFrom) To Ubound(tFrom) If tFrom(j) = Mid$(src$, i, Len(tFrom(j))) Then Exit For End If Next ' If a match was found, replace it in the output with the corresponding "replacewith" entry. If j <= Ubound(tFrom) Then res$ = res$ + tTo(min(Ubound(tTo), j)) i = i + max(0, Len(tFrom(j)) - 1) ' shift the input pointer past the end of the matching string so we don't match another string in the middle of it. Else ' Otherwise, copy over the one character at position i. res$ = res$ + Mid$(src$, i, 1) End If Next ReplaceSubstring = res$ End If End Function Function UIDAbbr(ids As Variant) ' This function performs roughly the same task as @Name([abbreviate]...); ' i.e., given an argument which is a string or array of strings, it returns ' the same string or array with the CN=, OU=, etc. stripped off of every ' hierarchical level of what is assumed to be a Notes username. ' ' Example: UIDAbbr("CN=Andre P. Guirard/OU=Nav/O=Hoptoad/C=US") ' returns "Andre P. Guirard/Nav/Hoptoad/US" If Isarray(ids) Then Dim i% Redim r(Lbound(ids) To Ubound(ids)) As String For i = Lbound(ids) To Ubound(ids) r(i) = UIDAbbr(ids(i)) Next UIDAbbr = r Else UIDAbbr = Trim(replacesubstring(Implode(vWord(Explode(vWord(Cstr(ids), "<@", 1), "/"), "=", -1), "/"), """", "")) End If End Function Function UIDCn(ids) ' This function performs roughly the same task as @Name([CN]...); ' ' Example: UIDCn("CN=Andre P. Guirard/OU=HiRollers/O=Gossamer/C=US") ' returns "Andre P. Guirard" ' ' If passed an array, it will process each element separately and return an ' array as a result. If Isarray(ids) Then Dim i% Redim r$(Lbound(ids) To Ubound(ids)) For i = Lbound(ids) To Ubound(ids) r$(i) = UIDCn(ids(i)) Next UIDCn = r$ Else UIDCn = Trim(Replacesubstring(vWord(vWord(Cstr(ids), "/<@", 1), "=", -1), """", "")) End If End Function Function Unique(a) Dim data List As Integer Dim i%, n% For i=Lbound(a) To Ubound(a) ' don't assume that the array starts at index 0. data( Cstr(a(i)) ) = i ' remember array index of original element. Next ' Take the new list and put it into a new array Redim newarray(0 To Ubound(a)-Lbound(a)) ' initially dimension array to maximum size we might need. Forall z In data newarray(n) = a(z) ' copying from the original array instead of the list tags lets us preserve the original datatype of the elements. n = n + 1 End Forall Redim Preserve newarray(0 To n-1) ' redimension the array only once, after we know how large it should be. Unique = newarray End Function Function vLeft(str_or_list, position) ' This reproduces the @Left function of the Notes macro language. 'Syntax: vLeft(str_or_list, position) ' where: ' str_or_list is a string or string array. ' position is either a number or a string. ' ' If 'position' is a number and str_or_list is a string, the first 'position' characters ' of the str_or_list are returned, or if str_or_list contains fewer than 'position' ' characters, the entire string. ' ' If 'position' is a string and str_or_list is a string, the result is the portion of ' str_or_list that precedes the first occurence of the string 'position' (case sensitive ' search). If 'position' is not found, the empty string is returned. ' ' If str_or_list is an array, the return value is an array where each element contains ' the result of the Left function on that element. Dim seekval As Variant Dim c% If Isarray(position) Then ' If position is an array use the first element as the search value. seekval = position(Lbound(position)) Else seekval = position End If ' If source string is an array, recursively process each array element. If Isarray(str_or_list) Then Redim result(Lbound(str_or_list) To Ubound(str_or_list)) For c = Lbound(result) To Ubound(result) result(c) = vLeft(str_or_list(c), seekval) Next vLeft = result Elseif Vartype(seekval) <> 8 Then vLeft = Left(str_or_list, seekval) Else Dim pos& pos = Instr(str_or_list, seekval) If pos = 0 Then vLeft = "" Else vLeft = Left(str_or_list, pos-1) End If End If End Function Function Repeat(s, Byval count As Integer) ' Given a string and a count, Repeat returns a string which is ' the argument value repeated "count" times. Passed an array, ' it returns an array where each element is the corresponding ' source element repeated "count" times. Dim i% If Isarray(s) Then Redim hark(Lbound(s) To Ubound(s)) As String For i = Lbound(s) To Ubound(s) hark(i) = Repeat(s(i), count) Next Repeat = hark Elseif Vartype(s) = 8 Then Select Case Len(s) Case 0: Repeat = "" ' empty string repeated any number of times is still empty. Case 1: Repeat = String(s, count) ' This is much faster than using a loop. Case Else Repeat = "" For i = 1 To count Repeat = Repeat & s Next End Select Else Repeat = Repeat(Cstr(s), count) End If End Function Function min(a,b) If a < b Then min = a Else min = b End If End Function Function max(a,b) If a < b Then max = b Else max = a End If End Function Function vRight(str_or_list, position) Dim seekval, c% If Isarray(position) Then seekval = position(Lbound(position)) Else seekval = position End If If Isarray(str_or_list) Then Redim result(Lbound(str_or_list) To Ubound(str_or_list)) For c = Lbound(result) To Ubound(result) result(c) = vRight(str_or_list(c), seekval) Next vRight = result Elseif Vartype(seekval) <> 8 Then vRight = Right(str_or_list, seekval) Else Dim pos& pos = Instr(str_or_list, seekval) If pos = 0 Then vRight = "" Else vRight = Mid(str_or_list, pos+Len(position)) End If End If End Function Function vWord(s, d$, i%) If Isarray(s) Then Dim j Redim r(0 To Ubound(s)-Lbound(s)) As String For j = 0 To Ubound(r) r(j) = vWord(s(j), d, i) Next vWord = r Else vWord = Word(Cstr(s), d, i) End If End Function Function vTrim(src, Byval options As Integer) ' src is either a string, or an array of strings. ' options is a set of bit flags corresponding to the constants defined above. If the VTRIM_TAB flag is set, ' we will treat tabs as whitespace, replacing them with spaces. If VTRIM_NEWLINE is set, newlines will ' be treated as whitespace. And if VTRIM_KEEP_NULL is set, null elements will not be removed from the ' array. Dim cc$, result$, i&, pos& If Isarray(src) Then ' recursively process each array element. Dim lim% lim = Lbound(src) Redim retval(lim To Ubound(src)) As String pos = lim For i = Lbound(src) To Ubound(src) result = vTrim(src(i), options) If result <> "" Or (options And VTRIM_KEEP_NULL) Then retval(pos) = result pos = pos + 1 End If Next Redim Preserve retval(lim To max(lim, pos-1)) vTrim = retval Else Dim state%, whitespace% For i = 1 To Len(src) cc = Mid(src, i, 1) ' The string is scanned with a state machine. ' State 0 means we have not yet encountered a non-whitespace character. ' State 1 means the last character was non-whitespace. ' State 2 means the last character was whitespace but there have been some non-whitespace. If (cc = " ") Then whitespace = True Elseif cc = Chr$(9) Then whitespace = (options And VTRIM_TAB) Elseif cc = Chr$(10) Or cc = Chr$(13) Then whitespace = (options And VTRIM_NEWLINE) Else whitespace = False End If Select Case state Case 0: If whitespace Then Else result = cc state = 1 End If Case 1: If whitespace Then state = 2 Else result = result + cc End If Case Else: If whitespace Then Else result = result + " " + cc state = 1 End If End Select Next vTrim = result End If ' src is an array. End Function Function Word(Sr$,Sk$,Byval P%) As String Dim Ls&, B&, S&, E&, rs&, re&, Lk&, I&, J&, cg$ Ls = Len(Sr) If P < 0 Then B = Ls Elseif P > 0 Then B = 1 Else Exit Function End If S = Sgn(P) E = Ls-B+1 rs = B-S re = E+S Lk = Len(Sk) For I = B To E Step S cg = Mid$(Sr,I,1) For J = 1 To Lk If Mid$(Sk,J,1) = cg Then Exit For End If Next If j <= Lk Then If Abs(P) = 1 Then re = i Exit For Else rs = i P = P - S End If End If Next If P = 1 Then Word = Mid$(Sr,rs+1,re-rs-1) Elseif P = -1 Then Word = Mid$(Sr,re+1,rs-re-1) End If End Function Function Binstr(Byval pos&, Byval s$, Byval t$) ' like Instr, only backwards. Find the last occurrence of t in s, preceding pos. Dim pastpos&, nextpos& nextpos = Instr(s, t) Do Until nextpos = 0 Or nextpos >= pos pastpos = nextpos nextpos = Instr(nextpos+1, s, t) Loop Binstr = pastpos End Function Function Begins(Byval a$, b) If Isarray(b) Then Dim i% For i = Lbound(b) To Ubound(b) If Begins(a, b(i)) Then Begins = True Exit Function End If Next Else Begins = (Left(a, Len(b)) = b) End If End Function Related Articles: |
