CSDN博客

img kezi

用LotusScript实现所有的公式语言

发表于2004/7/8 10:15:00  3020人阅读

分类: Lotus软件

用lotusScript实现的公式语言列表.
 
 @Adjust (2 forms)
 @Begins
 @BrowserInfo
 @ClientType
  @Contains
 @DbColumn
 @DbLookup
 @DbManager
 @DbName
  @DbTitle
 @Domain
 @Elements
 @Ends
 @Explode (3 forms)
  @GetPortsList
 @GetProfileField
 @Implode
 @IsAppInstalled
  @IsError
 @IsMember
 @IsNotMember
 @Keywords
  @LanguagePreference
 @Left
 @LeftBack
 @Length
 @Like
  @Locale
 @LowerCase
 @MailDbName
 @MailEncryptSavedPreference
  @MailEncryptSentPreference
 @MailSavePreference
 @MailSignPreference
  @Matches
 @Max
 @Member
 @Middle
 @MiddleBack
 @Min
  @Name
 @NameLookup
 @OptimizeMailAddress
 @Password
 @Platform
  @ProperCase
 @Repeat (2 forms)
 @Replace
 @ReplaceSubstring
  @Right
 @RightBack
 @Soundex
 @Subset
 @Sum
 @Text
  @Tomorrow
 @Trim
 @Unique
 @UpperCase
 @UserName
  @UserNameLanguage
 @UserNamesList
 @UserPrivileges
 @UserRoles
  @ValidateInternetAddress
 @Version
 @Word
 @Yesterday
 @Zone (2 forms)
 
 
在原作者中的lss文件中多了几行我修改了一下.试了一下他的函数,发现有好几个报错,不知是我试的不对还是原函数有问题.
不过总之是不错了. 非常方便,以后就不用再重复劳动去写了.
 
要使用这些函数只要在Options中加上
 
%INCLUDE "C:/lsformula.txt"  (假定存在C盘)
 
就可以使用所有的函数了.
 
(苛子注)
 
 
 
%REM ========================================================================================= Collection of LotusScript functions mapped onto @formula functions ------------------------------------------------------------------ Author: Jean-Pierre Ledure Date: Jan 2004 Release: 1.0 Lotus Notes release: tested in Lotus Notes 5.0.10 Free to %Include or import into a script library. How they work NOT FOR PURISTS ------------- The arguments of each function are transformed in a character string submitted for evaluation to the standard LotusScript EVALUATE function. Data type checking, array scanning, error handling, .. are included in a few internal functions that do the job. It is NOT an emulation of @formula functions in native LotusScript. Why this choice: 1. Most @functions support both SCALARS and LISTS as arguments: e.g. @ReplaceSubstring(sourceLIST, fromLIST, toLIST) => not easy to implement in native LS => document items are also LISTS 2. Such an implementation makes LS functions (almost) 100% compatible with the underlying @functions. 3. Introducing a new function is as easy as writing exactly 3 lines of code, including the Function and End function statements. 4. Many @functions are very practical, why not use them as such also in LS ? OF COURSE, the proposed implementation is not always optimal and performance can be an issue in some circumstances. The overhead must not be underestimated. Neither the opposite. @DbLookup and its LS equivalent are rather performant ! How to use ---------- Function name: identical to equivalent @formula function with next differences - no "@" - if name corresponds with reserved word of LotusScript, it is suffixed with an underscore (_): e.g. Name_, Left_, .. - if the @function supports optional arguments, a separate LS function must be defined for each fixed number of arguments. Its name is then suffixed with a sequence number Arguments can be of (almost) any format: Fixed or variable arrays Arrays based on variants Lists Scalar values Constant values if an argument is a symbolic constant ([OK], [CN], [Abbreviate]), surround it with quotes ("[OK]", ..) The resulting value is always a variant string, date, number or boolean array or scalar. If one is sure about the datatype, (s)he can assign it to a variable of the concerned datatype if relevant. When opportune, the resulting value can be tested with the IsError function. Additionnally ------------- The ListOperation (operand1,operation,operand2) function allows to execute on its first and third arguments the list operation given by its second, like in: ListOperation(array1, "+", array2) 'Concatenation of 2 arrays element by element Implemented functions (only those which make sense ... and those having accepted to work ...!) --------------------- @Adjust (2 forms) @Begins @BrowserInfo @ClientType @Contains @DbColumn @DbLookup @DbManager @DbName @DbTitle @Domain @Elements @Ends @Explode (3 forms) @GetPortsList @GetProfileField @Implode @IsAppInstalled @IsError @IsMember @IsNotMember @Keywords @LanguagePreference @Left @LeftBack @Length @Like @Locale @LowerCase @MailDbName @MailEncryptSavedPreference @MailEncryptSentPreference @MailSavePreference @MailSignPreference @Matches @Max @Member @Middle @MiddleBack @Min @Name @NameLookup @OptimizeMailAddress @Password @Platform @ProperCase @Repeat (2 forms) @Replace @ReplaceSubstring @Right @RightBack @Soundex @Subset @Sum @Text @Tomorrow @Trim @Unique @UpperCase @UserName @UserNameLanguage @UserNamesList @UserPrivileges @UserRoles @ValidateInternetAddress @Version @Word @Yesterday @Zone (2 forms) Examples -------- In next examples, it is equivalent and valid to declare the arrays as Dim array1(1 to 10) as String 'or Integer, Long, Variant, etc. array1(1) = ... ... Dim array1() Redim array1(1 to N) array1(1) = ... ... Dim array1 as List array1("A") = ... ... Dim array1 as Variant array1 = Evaluate(|"A":"B":"C"|) 'Why not ? ;=) ... Result is declared as: Dim Result as Variant ------------------------------- Returns a variant array of strings Result(0) => "London" Result(1) => "Frankfurt" Result(2) => "Tokyo" array1 = Evaluate(|"New Orleans":"London":"Frankfurt":"Tokyo"|) Result = Subset(array1, -3) Returns a string variable Result => "I hate peaches" array1 = Evaluate(|"like":"apples"|) array2 = Evaluate(|"hate":"peaches"|) Result = ReplaceSubstring("I like apples", array1, array2) Returns a date Result => Mar 15th 2004, 12:00 Result = Adjust(DateNumber(2003,12,31), 0, 2, 15, 12, 0, 0) Returns a variant array of strings Result(0) => "07/02/1996" Result(1) => "07/05/1996" array1 = Evaluate("[07/02/96 - 07/05/96]") Result = Explode(array1) Returns a variant array of strings Result(0) => "M" Result(1) => "nneapol" Result(2) => "s Detro" Result(3) => "t Ch" Result(4) => "cago" array1 = Evaluate(|"Minneapolis":"Detroit":"Chicago"|) Result = Explode2(Implode(array1), "i") Returns a variant array of strings Result(0) => "[...]" etc. Result = UserRoles() Returns a variant of boolean type Result => True Result = IsAppInstalled("Designer") Returns a variant of integer type Result => 4 array1 = Evaluate("3:5:9:12") Result = Elements(array1) Returns an error or a variant array array1 = Evaluate(|"":"NoCache"|) result = DbLookup(array1, "", "By approver", Name_("[CN]", UserName()), "Subject") If IsError(result) Then result = Unique2(Trim_(result)) ... Else ... End If %ENDREM Option Declare Const V_EMPTY = 0 ' Empty variant Const V_NULL = 1 ' Variant containing Null Const V_INTEGER = 2 ' Integer Const V_LONG = 3 ' Long integer (4 bytes) Const V_SINGLE = 4 ' Single Const V_DOUBLE = 5 ' Double Const V_CURRENCY = 6 ' Currency Const V_DATE = 7 ' Date value Const V_STRING = 8 ' String Const V_BOOLEAN = 11 ' BOOLEAN (from OLE only) Const V_VARIANT = 12 ' VARIANT array or list Const QUOTE = |"| Const BAR = "|" Const COLON = ":" Const SEMICOLON = ";" Const APOSTROPHE = "'" Const BACKSLASH = "/" Const MAXEVALLENGTH = 65535 Const FLAGERROR = "#ERROR#" Const USERERROR = 2000 Const INVALID = "Invalid formula" Const INVALIDTYPE = "Not supported datatype met" Const TOOLONG = "Too long formula string" Const PROPAGATE = "Previous error propagation" Const DEBUGTRACE = False ' Set True if debugging via the status bar can help Const ERRORTRACE = True ' Set True to get error messages in the status bar Dim ArrayType As Integer, ArrayIsArray As Variant Public Function ListOperation(operand1, operator, operand2) ' +++++++++++++++ 'Operands are lists or arrays on which operator is applied in a formula 'See "Operations on lists" in Domino Designer Help On Error Goto Error_Function Dim result As Variant, op1 As Variant, op2 As Variant op1 = Expand(operand1) If IsError(op1) Then Error USERERROR, INVALID op2 = Expand(operand2) If IsError(op2) Then Error USERERROR, INVALID On Error Goto Error_Function Dim EvalExpression As String EvalExpression = op1 & operator & op2 If Lenb(EvalExpression) > MAXEVALLENGTH Then Error USERERROR, TOOLONG If DEBUGTRACE Then If Len(EvalExpression) < 200 Then Print EvalExpression Else Print Len(EvalExpression), Left$(EvalExpression, 200) result = Evaluate(EvalExpression) If Isempty(result) Or Isnull(result) Then Error USERERROR, INVALID ListOperation = result If Isarray(result) Then If Lbound(result) = Ubound(result) Then ListOperation = result(Lbound(result)) Exit_Function: Exit Function Error_Function: If ERRORTRACE Then Print "LISTOPERATION: An error occurred (#" & Str(Err) & ") on line " & Str(Erl()) & " : " & Error$() ListOperation = FLAGERROR Resume Exit_Function End Function Public Function Adjust(DateToAdjust, Years, Months, Days, Hours, Minutes, Seconds) ' ++++++++ Adjust = EvalFormula("Adjust", _ DateToAdjust,Years,Months,Days,Hours,Minutes,Seconds, _ Null) End Function Public Function Adjust2(DateToAdjust, Years, Months, Days, Hours, Minutes, Seconds, DST) ' +++++++++ Adjust2 = EvalFormula("Adjust", _ DateToAdjust,Years,Months,Days,Hours,Minutes,Seconds,DST _ ) End Function Public Function Begins(textstring, substring) ' ++++++++ Begins = EvalFormula("Begins", _ textstring, substring, _ Null, Null, Null, Null, Null, Null) End Function Public Function BrowserInfo(propertyname) ' +++++++++++++ BrowserInfo = EvalFormula("BrowserInfo", _ propertyname, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function ClientType() ' ++++++++++++ ClientType = EvalFormula("ClientType", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Contains(textstring, substring) ' ++++++++++ Contains = EvalFormula("Contains", _ textstring, substring, _ Null, Null, Null, Null, Null, Null) End Function Public Function DbColumn(classNoCache, database, view, columnnumber) ' ++++++++++ DbColumn = EvalFormula("DbColumn", _ classNoCache, database, view, columnnumber, _ Null, Null, Null, Null) End Function Public Function DbLookup(classNoCache, database, view, key, columnnumber) ' ++++++++++ DbLookup = EvalFormula("DbLookup", _ classNoCache, database, view, key, columnnumber, _ Null, Null, Null) End Function Public Function DbManager() ' +++++++++++ DbManager = EvalFormula("DbManager", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function DbName() ' ++++++++ DbName = EvalFormula("DbName", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function DbTitle() ' +++++++++ DbTitle = EvalFormula("DbTitle", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Domain() ' ++++++++ Domain = EvalFormula("Domain", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Elements(array) ' ++++++++++ Elements = EvalFormula("Elements", _ array, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Ends(textstring, substring) ' ++++++ Ends = EvalFormula("Ends", _ textstring, substring, _ Null, Null, Null, Null, Null, Null) End Function Public Function Explode(stringordate) ' +++++++++ Explode = EvalFormula("Explode", _ stringordate, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Explode2(textstring, separator) ' ++++++++++ Explode2 = EvalFormula("Explode", _ textstring, separator, _ Null, Null, Null, Null, Null, Null) End Function Public Function Explode3(textstring, separator, includeEmpties) ' ++++++++++ Explode3 = EvalFormula("Explode", _ textstring, separator, includeEmpties, _ Null, Null, Null, Null, Null) End Function Public Function GetPortsList(portType) ' ++++++++++++++ GetPortsList = EvalFormula("GetPortsList", _ portType, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function GetProfileField(profilename, fieldname) ' +++++++++++++++++ GetProfileField = EvalFormula("GetProfileField", _ profilename, fieldname, _ Null, Null, Null, Null, Null, Null) End Function Public Function Implode(textlistValue) ' +++++++++ Implode = EvalFormula("Implode", _ textlistValue, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Implode2(textlistValue, separator) ' ++++++++++ Implode2 = EvalFormula("Implode", _ textlistValue, separator, _ Null, Null, Null, Null, Null, Null) End Function Public Function IsAppInstalled(app) ' ++++++++++++++++ IsAppInstalled = EvalFormula("IsAppInstalled", _ app, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function IsError(value) ' +++++++++ IsError = False If Isnull(value) Then IsError = True Exit Function End If Call Decode_Datatype(Datatype(value)) Select Case True Case ArrayIsArray And ArrayType = V_STRING If Islist(value) Then Forall elem In value If elem = FLAGERROR Then IsError = True Exit Forall 'Test on 1st element of list is sufficient End Forall Else If value(Lbound(value)) = FLAGERROR Then IsError = True End If Case Not ArrayIsArray And ArrayType = V_STRING If value = FLAGERROR Then IsError = True Case Else End Select End Function Public Function IsMember(textValue, textlistValue) ' ++++++++++ IsMember = EvalFormula("IsMember", _ textValue, textlistValue, _ Null, Null, Null, Null, Null, Null) End Function Public Function IsNotMember(textValue, textlistValue) ' +++++++++++++ IsNotMember = EvalFormula("IsNotMember", _ textValue, textlistValue, _ Null, Null, Null, Null, Null, Null) End Function Public Function Keywords(textList1, textList2) ' ++++++++++ Keywords = EvalFormula("Keywords", _ textList1, textList2, _ Null, Null, Null, Null, Null, Null) End Function Public Function Keywords2(textList1, textList2, separator) ' +++++++++++ Keywords2 = EvalFormula("Keywords", _ textList1, textList2, separator, _ Null, Null, Null, Null, Null) End Function Public Function LanguagePreference(key) ' ++++++++++++++++++++ LanguagePreference = EvalFormula("LanguagePreference", _ key, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Left_(stringToSearch, numberOfChars) ' +++++++ Left_ = EvalFormula("Left", _ stringToSearch, numberOfChars, _ Null, Null, Null, Null, Null, Null) End Function Public Function LeftBack(stringToSearch, numToSkip) ' ++++++++++ LeftBack = EvalFormula("LeftBack", _ stringToSearch, numToSkip, _ Null, Null, Null, Null, Null, Null) End Function Public Function Length(textlist) ' ++++++++ Length = EvalFormula("Length", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Like_(textstring, pattern) ' +++++++ Like_ = EvalFormula("Like", _ textstring, pattern, _ Null, Null, Null, Null, Null, Null) End Function Public Function Locale(action) ' ++++++++ Locale = EvalFormula("Locale", _ action, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Locale2(action, locale_tag) ' +++++++++ Locale2 = EvalFormula("Locale", _ action, locale_tag, _ Null, Null, Null, Null, Null, Null) End Function Public Function LowerCase(textlist) ' +++++++++++ LowerCase = EvalFormula("LowerCase", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function MailDbName() ' ++++++++++++ MailDbName = EvalFormula("MailDbName", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function MailEncryptSavedPreference() ' ++++++++++++++++++++++++++++ MailEncryptSavedPreference = EvalFormula("MailEncryptSavedPreference", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function MailEncryptSentPreference() ' +++++++++++++++++++++++++++ MailEncryptSentPreference = EvalFormula("MailEncryptSentPreference", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function MailSavePreference() ' ++++++++++++++++++++ MailSavePreference = EvalFormula("MailSavePreference", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function MailSignPreference() ' ++++++++++++++++++++ MailSignPreference = EvalFormula("MailSignPreference", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Matches(textstring, pattern) ' +++++++++ Matches = EvalFormula("Matches", _ textstring, pattern, _ Null, Null, Null, Null, Null, Null) End Function Public Function Max(number1, number2) ' +++++ Max = EvalFormula("Max", _ number1, number2, _ Null, Null, Null, Null, Null, Null) End Function Public Function Member(value, textlist) ' ++++++++ Member = EvalFormula("Member", _ value, textlist, _ Null, Null, Null, Null, Null, Null) End Function Public Function Middle(textlist, offset, numberchars) ' ++++++++ Middle = EvalFormula("Middle", _ textlist, offset, numberchars, _ Null, Null, Null, Null, Null) End Function Public Function MiddleBack(textlist, offset, numberchars) ' ++++++++++++ MiddleBack = EvalFormula("MiddleBack", _ textlist, offset, numberchars, _ Null, Null, Null, Null, Null) End Function Public Function Min(number1, number2) ' +++++ Min = EvalFormula("Min", _ number1, number2, _ Null, Null, Null, Null, Null, Null) End Function Public Function Name_(action, inname) ' +++++++ Name_ = EvalFormula("Name", _ action , inname, _ Null, Null, Null, Null, Null, Null) End Function Public Function NameLookup(flag, username, itemtoreturn) ' ++++++++++++ NameLookup = EvalFormula("NameLookup", _ flag, username, itemtoreturn, _ Null, Null, Null, Null, Null) End Function Public Function OptimizeMailAddress(address) ' +++++++++++++++++++++ OptimizeMailAddress = EvalFormula("OptimizeMailAddress", _ address, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Password(textstring) ' ++++++++++ Password = EvalFormula("Password", _ textstring, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Platform() ' ++++++++++ Platform = EvalFormula("Platform", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function ProperCase(textlist) ' ++++++++++++ ProperCase = EvalFormula("ProperCase", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Repeat(textlist, number) ' ++++++++ Repeat = EvalFormula("Repeat", _ textlist, number, _ Null, Null, Null, Null, Null, Null) End Function Public Function Repeat2(textlist, number, numberofchars) ' +++++++++ Repeat2 = EvalFormula("Repeat", _ textlist, number, numberofchars, _ Null, Null, Null, Null, Null) End Function Public Function Replace(sourceList, fromList, toList) ' +++++++++ Replace = EvalFormula("Replace", _ sourceList, fromList, toList, _ Null, Null, Null, Null, Null) End Function Public Function ReplaceSubstring(sourceList, fromList, toList) ' ++++++++++++++++++ ReplaceSubstring = EvalFormula("ReplaceSubstring", _ sourceList, fromList, toList, _ Null, Null, Null, Null, Null) End Function Public Function Right_(stringToSearch, numberOfChars) ' ++++++++ Right_ = EvalFormula("Right", _ stringToSearch, numberOfChars, _ Null, Null, Null, Null, Null, Null) End Function Public Function RightBack(stringToSearch, numToSkip) ' +++++++++++ RightBack = EvalFormula("RightBack", _ stringToSearch, numToSkip, _ Null, Null, Null, Null, Null, Null) End Function Public Function Soundex(textlist) ' +++++++++ Soundex = EvalFormula("Soundex", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Subset(textlist, number) ' ++++++++ Subset = EvalFormula("Subset", _ textlist, number, _ Null, Null, Null, Null, Null, Null) End Function Public Function Sum(numbers) ' +++++ Sum = EvalFormula("Sum", _ numbers, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Text_(value, formatstring) ' +++++++ Text_ = EvalFormula("Text", _ value, formatstring, _ Null, Null, Null, Null, Null, Null) End Function Public Function Tomorrow() ' ++++++++++ Tomorrow = EvalFormula("Tomorrow", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Trim_(textlist) ' +++++++ Trim_ = EvalFormula("Trim", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function Unique() ' ++++++++ Unique = EvalFormula("Unique", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Unique2(textlist) ' +++++++++ Unique2 = EvalFormula("Unique", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function UpperCase(textlist) ' +++++++++++ UpperCase = EvalFormula("UpperCase", _ textlist, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function UserName() ' ++++++++++ UserName = EvalFormula("UserName", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function UserNameLanguage(index) ' ++++++++++++++++++ UserNameLanguage = EvalFormula("UserNameLanguage", _ index, _ Null, Null, Null, Null, Null, Null, Null) End Function Public Function UserNamesList() ' +++++++++++++++ UserNamesList = EvalFormula("UserNamesList", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function UserPrivileges() ' ++++++++++++++++ UserPrivileges = EvalFormula("UserPrivileges", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function UserRoles() ' +++++++++++ UserRoles = EvalFormula("UserRoles", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function ValidateInternetAddress(keyword, address) ' +++++++++++++++++++++++++ ValidateInternetAddress = EvalFormula("ValidateInternetAddress", _ keyword, address, _ Null, Null, Null, Null, Null, Null) End Function Public Function Version() ' +++++++++ Version = EvalFormula("Version", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Word(textlist, separator, number) ' ++++++ Word = EvalFormula("Word", _ textlist, separator, number, _ Null, Null, Null, Null, Null) End Function Public Function Yesterday() ' +++++++++++ Yesterday = EvalFormula("Yesterday", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Zone() ' ++++++ Zone = EvalFormula("Zone", _ Null, Null, Null, Null, Null, Null, Null, Null) End Function Public Function Zone2(timedate) ' +++++++ Zone2 = EvalFormula("Zone", _ timedate, _ Null, Null, Null, Null, Null, Null, Null) End Function %REM ==================================================================================== Internal functions ==================================================================================== %ENDREM Private Function EvalFormula(functionstring As String, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8) ' +++++++++++++ On Error Goto Error_function If functionstring = "" Then Error USERERROR, INVALID Dim args(1 To 8) As Variant, EvalExpression As String, result As String, Eval As Variant args(1) = arg1 args(2) = arg2 args(3) = arg3 args(4) = arg4 args(5) = arg5 args(6) = arg6 args(7) = arg7 args(8) = arg8 Dim separator As String separator = "(" EvalExpression = "@" & functionstring Forall arg In args If Not Isnull(arg) Then result = Expand(arg) If result = FLAGERROR Then Error USERERROR, PROPAGATE EvalExpression = EvalExpression & separator & result separator = SEMICOLON Else Exit Forall End If End Forall If Not Isnull(arg1) Then EvalExpression = EvalExpression & ")" If DEBUGTRACE Then If Len(EvalExpression) < 200 Then Print EvalExpression Else Print Len(EvalExpression), Left$(EvalExpression, 200) If Lenb(EvalExpression) > MAXEVALLENGTH Then Error USERERROR, TOOLONG Eval = Evaluate(EvalExpression) If Isempty(eval) Or Isnull(eval) Then Error USERERROR, INVALID EvalFormula = Eval If Isarray(Eval) Then If Lbound(Eval) = Ubound(Eval) Then EvalFormula = Eval(Lbound(Eval)) Exit_Function: Exit Function Error_Function: If ERRORTRACE Then Print "EVALFORMULA: An error occurred (#" & Str(Err) & ") on line " & Str(Erl()) & " : " & Error$() EvalFormula = FLAGERROR Resume Exit_function End Function Private Function Expand(array As Variant) As String ' ++++++++ 'Transform, depending on data type of input array (string, number, date, ..), 'the argument in a list of scalar values separated by a colon. 'Objective: make array usable in an Evaluate function On Error Goto Error_Function Dim separator As String Dim nextstring As String Call Decode_Datatype(Datatype(array)) separator = "" Expand = "" If ArrayIsArray Then Forall item In array nextstring = ExpandItem(item) If nextstring = FLAGERROR Then Error USERERROR, PROPAGATE Expand = Expand & separator & nextstring separator = COLON End Forall Else nextstring = ExpandItem(array) If nextstring = FLAGERROR Then Error USERERROR, PROPAGATE Expand = nextstring End If Exit_Function: Exit Function Error_Function: If ERRORTRACE Then Print "EXPAND: An error occurred (#" & Str(Err) & ") on line " & Str(Erl()) & " : " & Error$() Expand = FLAGERROR Resume Exit_Function End Function Private Function ExpandItem(item As Variant) As String ' ++++++++++++ On Error Goto Error_Function Select Case ArrayType Case V_STRING If item = FLAGERROR Then ExpandItem = FLAGERROR Exit Function End If If Len(item) > 2 And Left$(item,1) = "[" And Right$(item,1) = "]" Then ExpandItem = item Else ExpandItem = QuotedString(item) End If Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY ExpandItem = Cstr(item) Case V_VARIANT If Isdate(item) Then ExpandItem = "@Date(" & _ Format$(Year(item)) & SEMICOLON & Format$(Month(item)) & SEMICOLON & Format$(Day(item)) & SEMICOLON & _ Format$(Hour(item)) & SEMICOLON & Format$(Minute(item)) & SEMICOLON & Format$(Second(item)) & _ ")" Else ExpandItem = Cstr(item) End If Case V_DATE ExpandItem = "@Date(" & _ Format$(Year(item)) & SEMICOLON & Format$(Month(item)) & SEMICOLON & Format$(Day(item)) & SEMICOLON & _ Format$(Hour(item)) & SEMICOLON & Format$(Minute(item)) & SEMICOLON & Format$(Second(item)) & _ ")" Case V_BOOLEAN If item Then ExpandItem = "@True" Else ExpandItem = "@False" Case Else Error USERERROR, INVALIDTYPE End Select Exit_Function: Exit Function Error_Function: If ERRORTRACE Then Print "EXPANDITEM: An error occurred (#" & Str(Err) & ") on line " & Str(Erl()) & " : " & Error$() ExpandItem = FLAGERROR Resume Exit_Function End Function Private Function QuotedString(Byval text As String) As String 'Quotes and backslashes in text must be preceeded by a backslash Dim subst(1 To 3) As String subst(1) = BACKSLASH 'Must be 1st subst(2) = QUOTE subst(3) = APOSTROPHE If text = "" Then QuotedString = QUOTE & QUOTE Exit Function End If Dim start As Integer, where As Integer, newtext As String Forall char In subst where = Instr(1, text, char) While where > 0 start = where + 2 newtext = Left$(text, where - 1) & BACKSLASH & char & Right$(text, Len(text) - where) text = newtext where = Instr(start, text, char) Wend End Forall QuotedString = QUOTE & text & QUOTE End Function Private Sub Decode_Datatype(DType As Integer) ' +++++++++++++++++ ' Determine array type and data type Select Case True Case DType >= 8704 'Dynamic array ArrayIsArray = True ArrayType = DType - 8704 Case DType >= 8192 'Fixed array ArrayIsArray = True ArrayType = DType - 8192 Case DType >= 2048 'List ArrayIsArray = True ArrayType = DType - 2048 Case Else ArrayIsArray = False ArrayType = DType End Select Exit Sub End Sub 
如有问题可到http://www.oaunion.com/oaunion/bbs.nsf讨论
 
0 0

相关博文

我的热门文章

img
取 消
img