oguruma
Modérateur
Inscrit le: 16 Déc 2004
Messages: 4210
Warnings: 0 
Spécialité: Non spécifié
Localisation: LILLE
Sexe: 
|
 Les Formules traduites en LS
Les sources ne sont pas de moi mais autant faire de la pub pour le site qui héberge ce code - certains le connaissent déjà -
http://www.openntf.org/Projects/codebin/codebin...386256E430040E783
et le source... si l'accès à ce site est impossible (sait-on jamais) - et merci à ces auteurs.
| Code: |
%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 Public
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
|
|
FAQ
Partenaires
Rechercher
Liste des Membres
Groupes d'utilisateurs
S'enregistrer
Connexion