diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 09:06:44 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 09:06:44 +0000 |
| commit | ed5640d8b587fbcfed7dd7967f3de04b37a76f26 (patch) | |
| tree | 7a5f7c6c9d02226d7471cb3cc8fbbf631b415303 /wizards/source/scriptforge/SF_Utils.xba | |
| parent | Initial commit. (diff) | |
| download | libreoffice-upstream.tar.xz libreoffice-upstream.zip | |
Adding upstream version 4:7.4.7.upstream/4%7.4.7upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/scriptforge/SF_Utils.xba | 1113 |
1 files changed, 1113 insertions, 0 deletions
diff --git a/wizards/source/scriptforge/SF_Utils.xba b/wizards/source/scriptforge/SF_Utils.xba new file mode 100644 index 000000000..91b703c46 --- /dev/null +++ b/wizards/source/scriptforge/SF_Utils.xba @@ -0,0 +1,1113 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Utils" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Explicit +Option Private Module + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Utils +''' ======== +''' FOR INTERNAL USE ONLY +''' Groups all private functions used by the official modules +''' Declares the Global variable _SF_ +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ===================================================================== GLOBALS + +Global _SF_ As Variant ' SF_Root (Basic) object) + +''' ScriptForge version +Const SF_Version = "7.4" + +''' Standard symbolic names for VarTypes +' V_EMPTY = 0 +' V_NULL = 1 +' V_INTEGER = 2 +' V_LONG = 3 +' V_SINGLE = 4 +' V_DOUBLE = 5 +' V_CURRENCY = 6 +' V_DATE = 7 +' V_STRING = 8 +''' Additional symbolic names for VarTypes +Global Const V_OBJECT = 9 +Global Const V_BOOLEAN = 11 +Global Const V_VARIANT = 12 +Global Const V_BYTE = 17 +Global Const V_USHORT = 18 +Global Const V_ULONG = 19 +Global Const V_BIGINT = 35 +Global Const V_DECIMAL = 37 +Global Const V_ARRAY = 8192 +''' Fictive VarTypes +Global Const V_NUMERIC = 99 ' Synonym of any numeric value [returned by _VarTypeExt()] +Global Const V_NOTHING = 101 ' Object categories [returned by _VarTypeObj()] Null object +Global Const V_UNOOBJECT = 102 ' Uno object or Uno structure +Global Const V_SFOBJECT = 103 ' ScriptForge object: has ObjectType and ServiceName properties +Global Const V_BASICOBJECT = 104 ' User Basic object + +Type _ObjectDescriptor ' Returned by the _VarTypeObj() method + iVarType As Integer ' One of the V_NOTHING, V_xxxOBJECT constants + sObjectType As String ' Either "" or "com.sun.star..." or a ScriptForge object type (ex. "SF_SESSION" or "DICTIONARY") + sServiceName As String ' Either "" or the service name of a ScriptForge object type (ex. "ScriptForge.Exception"- +End Type + +REM ================================================================== EXCEPTIONS + +Const MISSINGARGERROR = "MISSINGARGERROR" ' A mandatory argument is missing +Const ARGUMENTERROR = "ARGUMENTERROR" ' An argument does not pass the _Validate() validation +Const ARRAYERROR = "ARRAYERROR" ' An argument does not pass the _ValidateArray() validation +Const FILEERROR = "FILEERROR" ' An argument does not pass the _ValidateFile() validation + +REM =========================================pvA==================== PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Public Function _CDateToIso(pvDate As Variant) As Variant +''' Returns a string representation of the given Basic date +''' Dates as strings are essential in property values, where Basic dates are evil + +Dim sIsoDate As Variant ' Return value + + If VarType(pvDate) = V_DATE Then + If Year(pvDate) < 1900 Then ' Time only + sIsoDate = Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) & ":" & Right("0" & Second(pvDate), 2) + ElseIf Hour(pvDate) + Minute(pvDate) + Second(pvDate) = 0 Then ' Date only + sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2) + Else + sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2) _ + & " " & Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) _ + & ":" & Right("0" & Second(pvDate), 2) + End If + Else + sIsoDate = pvDate + End If + + _CDateToIso = sIsoDate + +End Function ' ScriptForge.SF_Utils._CDateToIso + +REM ----------------------------------------------------------------------------- +Public Function _CDateToUnoDate(pvDate As Variant) As Variant +''' Returns a UNO com.sun.star.util.DateTime/Date/Time object depending on the given date +''' by using the appropriate CDateToUnoDateXxx builtin function +''' UNO dates are essential in property values, where Basic dates are evil + +Dim vUnoDate As Variant ' Return value + + If VarType(pvDate) = V_DATE Then + If Year(pvDate) < 1900 Then + vUnoDate = CDateToUnoTime(pvDate) + ElseIf Hour(pvDate) + Minute(pvDate) + Second(pvDate) = 0 Then + vUnoDate = CDateToUnoDate(pvDate) + Else + vUnoDate = CDateToUnoDateTime(pvDate) + End If + Else + vUnoDate = pvDate + End If + + _CDateToUnoDate = vUnoDate + +End Function ' ScriptForge.SF_Utils._CDateToUnoDate + +REM ----------------------------------------------------------------------------- +Public Function _CPropertyValue(ByRef pvValue As Variant) As Variant +''' Set a value of a correct type in a com.sun.star.beans.PropertyValue +''' Date BASIC variables give error. Change them to UNO types +''' Empty arrays should be replaced by Null + +Dim vValue As Variant ' Return value + + If VarType(pvValue) = V_DATE Then + vValue = SF_Utils._CDateToUnoDate(pvValue) + ElseIf IsArray(pvValue) Then + If UBound(pvValue, 1) < LBound(pvValue, 1) Then vValue = Null Else vValue = pvValue + Else + vValue = pvValue + End If + _CPropertyValue() = vValue + +End Function ' ScriptForge.SF_Utils._CPropertyValue + +REM ----------------------------------------------------------------------------- +Public Function _CStrToDate(ByRef pvStr As String) As Date +''' Attempt to convert the input string to a Date variable with the CDate builtin function +''' If not successful, returns conventionally -1 (29/12/1899) +''' Date patterns: YYYY-MM-DD, HH:MM:DD and YYYY-MM-DD HH:MM:DD + +Dim dDate As Date ' Return value +Const cstNoDate = -1 + + dDate = cstNoDate +Try: + On Local Error Resume Next + dDate = CDate(pvStr) + +Finally: + _CStrToDate = dDate + Exit Function +End Function ' ScriptForge.SF_Utils._CStrToDate + +REM ----------------------------------------------------------------------------- +Public Function _EnterFunction(ByVal psSub As String, Optional ByVal psArgs As String) +''' Called on top of each public function +''' Used to trace routine in/outs (debug mode) +''' and to allow the explicit mention of the user call which caused an error +''' Args: +''' psSub = the called Sub/Function/Property, usually something like "service.sub" +''' Return: True when psSub is called from a user script +''' Used to bypass the validation of the arguments when unnecessary + + If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session + If IsMissing(psArgs) Then psArgs = "" + With _SF_ + If .StackLevel = 0 Then + .MainFunction = psSub + .MainFunctionArgs = psArgs + _EnterFunction = True + Else + _EnterFunction = False + End If + .StackLevel = .StackLevel + 1 + If .DebugMode Then ._AddToConsole("==> " & psSub & "(" & .StackLevel & ")") + End With + +End Function ' ScriptForge.SF_Utils._EnterFunction + +REM ----------------------------------------------------------------------------- +Public Function _ErrorHandling(Optional ByVal pbErrorHandler As Boolean) As Boolean +''' Error handling is normally ON and can be set OFF for debugging purposes +''' Each user visible routine starts with a call to this function to enable/disable +''' standard handling of internal errors +''' Args: +''' pbErrorHandler = if present, set its value +''' Return: the current value of the error handler + + If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session + If Not IsMissing(pbErrorHandler) Then _SF_.ErrorHandler = pbErrorHandler + _ErrorHandling = _SF_.ErrorHandler + +End Function ' ScriptForge.SF_Utils._ErrorHandling + +REM ----------------------------------------------------------------------------- +Public Sub _ExitFunction(ByVal psSub As String) +''' Called in the Finally block of each public function +''' Manage ScriptForge internal aborts +''' Resets MainFunction (root) when exiting the method called by a user script +''' Used to trace routine in/outs (debug mode) +''' Args: +''' psSub = the called Sub/Function/Property, usually something like "service.sub" + + If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' Useful only when current module has been recompiled + With _SF_ + If Err > 0 Then + SF_Exception.RaiseAbort(psSub) + End If + If .StackLevel = 1 Then + .MainFunction = "" + .MainFunctionArgs = "" + End If + If .DebugMode Then ._AddToConsole("<== " & psSub & "(" & .StackLevel & ")") + If .StackLevel > 0 Then .StackLevel = .StackLevel - 1 + End With + +End Sub ' ScriptForge.SF_Utils._ExitFunction + +REM ----------------------------------------------------------------------------- +Public Sub _ExportScriptForgePOTFile(ByVal FileName As String) +''' Export the ScriptForge POT file related to its own user interface +''' Should be called only before issuing new ScriptForge releases only +''' Args: +''' FileName: the resulting file. If it exists, is overwritten without warning + +Dim sHeader As String ' The specific header to insert + + sHeader = "" _ + & "*********************************************************************\n" _ + & "*** The ScriptForge library and its associated libraries ***\n" _ + & "*** are part of the LibreOffice project. ***\n" _ + & "*********************************************************************\n" _ + & "\n" _ + & "ScriptForge Release " & SF_Version & "\n" _ + & "-----------------------" + +Try: + With _SF_ + If Not IsNull(.LocalizedInterface) Then .LocalizedInterface.Dispose() + ._LoadLocalizedInterface(psMode := "ADDTEXT") ' Force reload of labels from the code + .LocalizedInterface.ExportToPOTFile(FileName, Header := sHeader) + End With + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_Utils._ExportScriptForgePOTFile + +REM ----------------------------------------------------------------------------- +Public Function _GetPropertyValue(ByRef pvArgs As Variant, ByVal psName As String) As Variant +''' Returns the Value corresponding to the given name +''' Args +''' pvArgs: a zero_based array of PropertyValues +''' psName: the comparison is not case-sensitive +''' Returns: +''' Zero-length string if not found + +Dim vValue As Variant ' Return value +Dim i As Long + + vValue = "" + If IsArray(pvArgs) Then + For i = LBound(pvArgs) To UBound(pvArgs) + If UCase(psName) = UCase(pvArgs(i).Name) Then + vValue = pvArgs(i).Value + Exit For + End If + Next i + End If + _GetPropertyValue = vValue + +End Function ' ScriptForge.SF_Utils._GetPropertyValue + +REM ----------------------------------------------------------------------------- +Public Function _GetRegistryKeyContent(ByVal psKeyName as string _ + , Optional pbForUpdate as Boolean _ + ) As Variant +''' Implement a ConfigurationProvider service +''' Derived from the Tools library +''' Args: +''' psKeyName: the name of the node in the configuration tree +''' pbForUpdate: default = False + +Dim oConfigProvider as Object ' com.sun.star.configuration.ConfigurationProvider +Dim vNodePath(0) as New com.sun.star.beans.PropertyValue +Dim sConfig As String ' One of next 2 constants +Const cstConfig = "com.sun.star.configuration.ConfigurationAccess" +Const cstConfigUpdate = "com.sun.star.configuration.ConfigurationUpdateAccess" + + Set oConfigProvider = _GetUNOService("ConfigurationProvider") + vNodePath(0).Name = "nodepath" + vNodePath(0).Value = psKeyName + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If pbForUpdate Then sConfig = cstConfigUpdate Else sConfig = cstConfig + + Set _GetRegistryKeyContent = oConfigProvider.createInstanceWithArguments(sConfig, vNodePath()) + +End Function ' ScriptForge.SF_Utils._GetRegistryKeyContent + +REM ----------------------------------------------------------------------------- +Private Function _GetSetting(ByVal psPreference As String, psProperty As String) As Variant +''' Find in the configuration a specific setting based on its location in the +''' settings registry + +Dim oConfigProvider As Object ' com.sun.star.configuration.ConfigurationProvider +Dim vNodePath As Variant ' Array of com.sun.star.beans.PropertyValue + + ' Derived from the Tools library + Set oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") + vNodePath = Array(SF_Utils._MakePropertyValue("nodepath", psPreference)) + + _GetSetting = oConfigProvider.createInstanceWithArguments( _ + "com.sun.star.configuration.ConfigurationAccess", vNodePath()).getByName(psProperty) + +End Function ' ScriptForge.SF_Utils._GetSetting + +REM ----------------------------------------------------------------------------- +Public Function _GetUNOService(ByVal psService As String _ + , Optional ByVal pvArg As Variant _ + ) As Object +''' Create a UNO service +''' Each service is called only once +''' Args: +''' psService: shortcut to service +''' pvArg: some services might require an argument + +Dim sLocale As String ' fr-BE f.i. +Dim oDefaultContext As Object + + Set _GetUNOService = Nothing + With _SF_ + Select Case psService + Case "BrowseNodeFactory" + Set oDefaultContext = GetDefaultContext() + If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.script.browse.theBrowseNodeFactory") + Case "CalendarImpl" + If IsEmpty(.CalendarImpl) Or IsNull(.CalendarImpl) Then + Set .CalendarImpl = CreateUnoService("com.sun.star.i18n.CalendarImpl") + End If + Set _GetUNOService = .CalendarImpl + Case "CharacterClass" + If IsEmpty(.CharacterClass) Or IsNull(.CharacterClass) Then + Set .CharacterClass = CreateUnoService("com.sun.star.i18n.CharacterClassification") + End If + Set _GetUNOService = .CharacterClass + Case "ConfigurationProvider" + If IsEmpty(.ConfigurationProvider) Or IsNull(.ConfigurationProvider) Then + Set .ConfigurationProvider = CreateUnoService("com.sun.star.configuration.ConfigurationProvider") + End If + Set _GetUNOService = .ConfigurationProvider + Case "CoreReflection" + If IsEmpty(.CoreReflection) Or IsNull(.CoreReflection) Then + Set .CoreReflection = CreateUnoService("com.sun.star.reflection.CoreReflection") + End If + Set _GetUNOService = .CoreReflection + Case "DatabaseContext" + If IsEmpty(.DatabaseContext) Or IsNull(.DatabaseContext) Then + Set .DatabaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + End If + Set _GetUNOService = .DatabaseContext + Case "DispatchHelper" + If IsEmpty(.DispatchHelper) Or IsNull(.DispatchHelper) Then + Set .DispatchHelper = CreateUnoService("com.sun.star.frame.DispatchHelper") + End If + Set _GetUNOService = .DispatchHelper + Case "FileAccess" + If IsEmpty(.FileAccess) Or IsNull(.FileAccess) Then + Set .FileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + End If + Set _GetUNOService = .FileAccess + Case "FilePicker" + If IsEmpty(.FilePicker) Or IsNull(.FilePicker) Then + Set .FilePicker = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") + End If + Set _GetUNOService = .FilePicker + Case "FilterFactory" + If IsEmpty(.FilterFactory) Or IsNull(.FilterFactory) Then + Set .FilterFactory = CreateUnoService("com.sun.star.document.FilterFactory") + End If + Set _GetUNOService = .FilterFactory + Case "FolderPicker" + If IsEmpty(.FolderPicker) Or IsNull(.FolderPicker) Then + Set .FolderPicker = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker") + End If + Set _GetUNOService = .FolderPicker + Case "FormatLocale" + If IsEmpty(.FormatLocale) Or IsNull(.FormatLocale) Then + .FormatLocale = CreateUnoStruct("com.sun.star.lang.Locale") + ' 1st and 2nd chance + sLocale = SF_Utils._GetSetting("org.openoffice.Setup/L10N", "ooSetupSystemLocale") + If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale") + .FormatLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always + .FormatLocale.Country = Right(sLocale, 2) + End If + Set _GetUNOService = .FormatLocale + Case "FunctionAccess" + If IsEmpty(.FunctionAccess) Or IsNull(.FunctionAccess) Then + Set .FunctionAccess = CreateUnoService("com.sun.star.sheet.FunctionAccess") + End If + Set _GetUNOService = .FunctionAccess + Case "GraphicExportFilter" + If IsEmpty(.GraphicExportFilter) Or IsNull(.GraphicExportFilter) Then + Set .GraphicExportFilter = CreateUnoService("com.sun.star.drawing.GraphicExportFilter") + End If + Set _GetUNOService = .GraphicExportFilter + Case "Introspection" + If IsEmpty(.Introspection) Or IsNull(.Introspection) Then + Set .Introspection = CreateUnoService("com.sun.star.beans.Introspection") + End If + Set _GetUNOService = .Introspection + Case "LocaleData" + If IsEmpty(.LocaleData) Or IsNull(.LocaleData) Then + Set .LocaleData = CreateUnoService("com.sun.star.i18n.LocaleData") + End If + Set _GetUNOService = .LocaleData + Case "MacroExpander" + Set oDefaultContext = GetDefaultContext() + If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.util.theMacroExpander") + Case "MailService" + If IsEmpty(.MailService) Or IsNull(.MailService) Then + If GetGuiType = 1 Then ' Windows + Set .MailService = CreateUnoService("com.sun.star.system.SimpleSystemMail") + Else + Set .MailService = CreateUnoService("com.sun.star.system.SimpleCommandMail") + End If + End If + Set _GetUNOService = .MailService + Case "Number2Text" + If IsEmpty(.Number2Text) Or IsNull(.Number2Text) Then + Set .Number2Text = CreateUnoService("com.sun.star.linguistic2.NumberText") + End If + Set _GetUNOService = .Number2Text + Case "OfficeLocale" + If IsEmpty(.OfficeLocale) Or IsNull(.OfficeLocale) Then + .OfficeLocale = CreateUnoStruct("com.sun.star.lang.Locale") + ' 1st and 2nd chance + sLocale = SF_Utils._GetSetting("org.openoffice.Setup/L10N", "ooLocale") + If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale") + .OfficeLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always + .OfficeLocale.Country = Right(sLocale, 2) + End If + Set _GetUNOService = .OfficeLocale + Case "PackageInformationProvider" + If IsEmpty(.PackageProvider) Or IsNull(.PackageProvider) Then + Set .PackageProvider = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider") + End If + Set _GetUNOService = .PackageProvider + Case "PathSettings" + If IsEmpty(.PathSettings) Or IsNull(.PathSettings) Then + Set .PathSettings = CreateUnoService("com.sun.star.util.PathSettings") + End If + Set _GetUNOService = .PathSettings + Case "PathSubstitution" + If IsEmpty(.PathSubstitution) Or IsNull(.PathSubstitution) Then + Set .PathSubstitution = CreateUnoService("com.sun.star.util.PathSubstitution") + End If + Set _GetUNOService = .PathSubstitution + Case "PrinterServer" + If IsEmpty(.PrinterServer) Or IsNull(.PrinterServer) Then + Set .PrinterServer = CreateUnoService("com.sun.star.awt.PrinterServer") + End If + Set _GetUNOService = .PrinterServer + Case "ScriptProvider" + If IsMissing(pvArg) Then pvArg = SF_Session.SCRIPTISAPPLICATION + Select Case LCase(pvArg) + Case SF_Session.SCRIPTISEMBEDDED ' Document + If Not IsNull(ThisComponent) Then Set _GetUNOService = ThisComponent.getScriptProvider() + Case Else + If IsEmpty(.ScriptProvider) Or IsNull(.ScriptProvider) Then + Set .ScriptProvider = _ + CreateUnoService("com.sun.star.script.provider.MasterScriptProviderFactory").createScriptProvider("") + End If + Set _GetUNOService = .ScriptProvider + End Select + Case "SearchOptions" + If IsEmpty(.SearchOptions) Or IsNull(.SearchOptions) Then + Set .SearchOptions = New com.sun.star.util.SearchOptions + With .SearchOptions + .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP + .searchFlag = 0 + End With + End If + Set _GetUNOService = .SearchOptions + Case "SystemLocale", "Locale" + If IsEmpty(.SystemLocale) Or IsNull(.SystemLocale) Then + .SystemLocale = CreateUnoStruct("com.sun.star.lang.Locale") + sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "SystemLocale") + .SystemLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always + .SystemLocale.Country = Right(sLocale, 2) + End If + Set _GetUNOService = .SystemLocale + Case "SystemShellExecute" + If IsEmpty(.SystemShellExecute) Or IsNull(.SystemShellExecute) Then + Set .SystemShellExecute = CreateUnoService("com.sun.star.system.SystemShellExecute") + End If + Set _GetUNOService = .SystemShellExecute + Case "TextSearch" + If IsEmpty(.TextSearch) Or IsNull(.TextSearch) Then + Set .TextSearch = CreateUnoService("com.sun.star.util.TextSearch") + End If + Set _GetUNOService = .TextSearch + Case "Toolkit" + If IsEmpty(.Toolkit) Or IsNull(.Toolkit) Then + Set .Toolkit = CreateUnoService("com.sun.star.awt.Toolkit") + End If + Set _GetUNOService = .Toolkit + Case "URLTransformer" + If IsEmpty(.URLTransformer) Or IsNull(.URLTransformer) Then + Set .URLTransformer = CreateUnoService("com.sun.star.util.URLTransformer") + End If + Set _GetUNOService = .URLTransformer + Case Else + End Select + End With + +End Function ' ScriptForge.SF_Utils._GetUNOService + +REM ----------------------------------------------------------------------------- +Public Sub _InitializeRoot(Optional ByVal pbForce As Boolean) +''' Initialize _SF_ as SF_Root basic object +''' Args: +''' pbForce = True forces the reinit (default = False) + + If IsMissing(pbForce) Then pbForce = False + If pbForce Then Set _SF_ = Nothing + If IsEmpty(_SF_) Or IsNull(_SF_) Then + Set _SF_ = New SF_Root + Set _SF_.[Me] = _SF_ + End If + +End Sub ' ScriptForge.SF_Utils._InitializeRoot + +REM ----------------------------------------------------------------------------- +Public Function _MakePropertyValue(ByVal psName As String _ + , ByRef pvValue As Variant _ + ) As com.sun.star.beans.PropertyValue +''' Create and return a new com.sun.star.beans.PropertyValue + +Dim oPropertyValue As New com.sun.star.beans.PropertyValue + + With oPropertyValue + .Name = psName + .Value = SF_Utils._CPropertyValue(pvValue) + End With + _MakePropertyValue() = oPropertyValue + +End Function ' ScriptForge.SF_Utils._MakePropertyValue + +REM ----------------------------------------------------------------------------- +Public Function _Repr(ByVal pvArg As Variant, Optional ByVal plMax As Long) As String +''' Convert pvArg into a readable string (truncated if length > plMax) +''' Args +''' pvArg: may be of any type +''' plMax: maximum length of the resulting string (default = 32K) + +Dim sArg As String ' Return value +Dim oObject As Object ' Alias of argument to avoid "Object variable not set" +Dim oObjectDesc As Object ' Object descriptor +Dim sLength As String ' String length as a string +Dim i As Long +Const cstBasicObject = "com.sun.star.script.NativeObjectWrapper" + +Const cstMaxLength = 2^15 - 1 ' 32767 +Const cstByteLength = 25 +Const cstEtc = " … " + + If IsMissing(plMax) Then plMax = cstMaxLength + If plMax = 0 Then plMax = cstMaxLength + If IsArray(pvArg) Then + sArg = SF_Array._Repr(pvArg) + Else + Select Case VarType(pvArg) + Case V_EMPTY : sArg = "[EMPTY]" + Case V_NULL : sArg = "[NULL]" + Case V_OBJECT + Set oObjectDesc = SF_Utils._VarTypeObj(pvArg) + With oObjectDesc + Select Case .iVarType + Case V_NOTHING : sArg = "[NOTHING]" + Case V_OBJECT, V_BASICOBJECT + sArg = "[OBJECT]" + Case V_UNOOBJECT : sArg = "[" & .sObjectType & "]" + Case V_SFOBJECT + If Left(.sObjectType, 3) = "SF_" Then ' Standard module + sArg = "[" & .sObjectType & "]" + Else ' Class module must have a _Repr() method + Set oObject = pvArg + sArg = oObject._Repr() + End If + End Select + End With + Case V_VARIANT : sArg = "[VARIANT]" + Case V_STRING + sArg = SF_String._Repr(pvArg) + Case V_BOOLEAN : sArg = Iif(pvArg, "[TRUE]", "[FALSE]") + Case V_BYTE : sArg = Right("00" & Hex(pvArg), 2) + Case V_SINGLE, V_DOUBLE, V_CURRENCY + sArg = Format(pvArg) + If InStr(1, sArg, "E", 1) = 0 Then sArg = Format(pvArg, "##0.0##") + sArg = Replace(sArg, ",", ".") 'Force decimal point + Case V_BIGINT : sArg = CStr(CLng(pvArg)) + Case V_DATE : sArg = _CDateToIso(pvArg) + Case Else : sArg = CStr(pvArg) + End Select + End If + If Len(sArg) > plMax Then + sLength = "(" & Len(sArg) & ")" + sArg = Left(sArg, plMax - Len(cstEtc) - Len(slength)) & cstEtc & sLength + End If + _Repr = sArg + +End Function ' ScriptForge.SF_Utils._Repr + +REM ----------------------------------------------------------------------------- +Private Function _ReprValues(Optional ByVal pvArgs As Variant _ + , Optional ByVal plMax As Long _ + ) As String +''' Convert an array of values to a comma-separated list of readable strings + +Dim sValues As String ' Return value +Dim sValue As String ' A single value +Dim vValue As Variant ' A single item in the argument +Dim i As Long ' Items counter +Const cstMax = 20 ' Maximum length of single string +Const cstContinue = "…" ' Unicode continuation char U+2026 + + _ReprValues = "" + If IsMissing(pvArgs) Then Exit Function + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) + sValues = "" + For i = 0 To UBound(pvArgs) + vValue = pvArgs(i) + If i < plMax Then + If VarType(vValue) = V_STRING Then sValue = """" & vValue & """" Else sValue = SF_Utils._Repr(vValue, cstMax) + If Len(sValues) = 0 Then sValues = sValue Else sValues = sValues & ", " & sValue + ElseIf i < UBound(pvArgs) Then + sValues = sValues & ", " & cstContinue + Exit For + End If + Next i + _ReprValues = sValues + +End Function ' ScriptForge.SF_Utils._ReprValues + +REM ----------------------------------------------------------------------------- +Public Function _SetPropertyValue(ByVal pvPropertyValue As Variant _ + , ByVal psName As String _ + , ByRef pvValue As Variant _ + ) As Variant +''' Return the 1st argument (passed by reference), which is an array of property values +''' If the property psName exists, update it with pvValue, otherwise create it on top of the returned array + +Dim oPropertyValue As New com.sun.star.beans.PropertyValue +Dim lIndex As Long ' Found entry +Dim vValue As Variant ' Alias of pvValue +Dim vProperties As Variant ' Alias of pvPropertyValue +Dim i As Long + + lIndex = -1 + vProperties = pvPropertyValue + For i = 0 To UBound(vProperties) + If vProperties(i).Name = psName Then + lIndex = i + Exit For + End If + Next i + If lIndex < 0 Then ' Not found + lIndex = UBound(vProperties) + 1 + ReDim Preserve vProperties(0 To lIndex) + Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue) + vProperties(lIndex) = oPropertyValue + vProperties = vProperties + Else ' psName exists already in array of property values + vProperties(lIndex).Value = SF_Utils._CPropertyValue(pvValue) + End If + + _SetPropertyValue = vProperties + +End Function ' ScriptForge.SF_Utils._SetPropertyValue + +REM ----------------------------------------------------------------------------- +Private Function _TypeNames(Optional ByVal pvArgs As Variant) As String +''' Converts the array of VarTypes to a comma-separated list of TypeNames + +Dim sTypes As String ' Return value +Dim sType As String ' A single type +Dim iType As Integer ' A single item of the argument + + _TypeNames = "" + If IsMissing(pvArgs) Then Exit Function + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) + sTypes = "" + For Each iType In pvArgs + Select Case iType + Case V_EMPTY : sType = "Empty" + Case V_NULL : sType = "Null" + Case V_INTEGER : sType = "Integer" + Case V_LONG : sType = "Long" + Case V_SINGLE : sType = "Single" + Case V_DOUBLE : sType = "Double" + Case V_CURRENCY : sType = "Currency" + Case V_DATE : sType = "Date" + Case V_STRING : sType = "String" + Case V_OBJECT : sType = "Object" + Case V_BOOLEAN : sType = "Boolean" + Case V_VARIANT : sType = "Variant" + Case V_DECIMAL : sType = "Decimal" + Case >= V_ARRAY : sType = "Array" + Case V_NUMERIC : sType = "Numeric" + End Select + If Len(sTypes) = 0 Then sTypes = sType Else sTypes = sTypes & ", " & sType + Next iType + _TypeNames = sTypes + +End Function ' ScriptForge.SF_Utils._TypeNames + +REM ----------------------------------------------------------------------------- +Public Function _Validate(Optional ByRef pvArgument As Variant _ + , ByVal psName As String _ + , Optional ByVal pvTypes As Variant _ + , Optional ByVal pvValues As Variant _ + , Optional ByVal pvRegex As Variant _ + , Optional ByVal pvObjectType As Variant _ + ) As Boolean +''' Validate the arguments set by user scripts +''' The arguments of the function define the validation rules +''' This function ignores arrays. Use _ValidateArray instead +''' Args: +''' pvArgument: the argument to (in)validate +''' psName: the documented name of the argument (can be inserted in an error message) +''' pvTypes: array of allowed VarTypes +''' pvValues: array of allowed values +''' pvRegex: regular expression to comply with +''' pvObjectType: mandatory Basic class +''' Return: True if validation OK +''' Otherwise an error is raised +''' Exceptions: +''' ARGUMENTERROR + +Dim iVarType As Integer ' Extended VarType of argument +Dim bValid As Boolean ' Returned value +Dim oObjectDescriptor As Object ' _ObjectDescriptor type +Const cstMaxLength = 256 ' Maximum length of readable value +Const cstMaxValues = 10 ' Maximum number of allowed items to list in an error message + + ' To avoid useless recursions, keep main function, only increase stack depth + _SF_.StackLevel = _SF_.StackLevel + 1 + On Local Error GoTo Finally ' Do never interrupt + +Try: + bValid = True + If IsMissing(pvArgument) Then GoTo CatchMissing + If IsMissing(pvRegex) Or IsEmpty(pvRegex) Then pvRegex = "" + If IsMissing(pvObjectType) Or IsEmpty(pvObjectType) Then pvObjectType = "" + iVarType = SF_Utils._VarTypeExt(pvArgument) + + ' Arrays NEVER pass validation + If iVarType >= V_ARRAY Then + bValid = False + Else + ' Check existence of argument + bValid = iVarType <> V_NULL And iVarType <> V_EMPTY + ' Check if argument's VarType is valid + If bValid And Not IsMissing(pvTypes) Then + If Not IsArray(pvTypes) Then bValid = ( pvTypes = iVarType ) Else bValid = SF_Array.Contains(pvTypes, iVarType) + End If + ' Check if argument's value is valid + If bValid And Not IsMissing(pvValues) Then + If Not IsArray(pvValues) Then pvValues = Array(pvValues) + bValid = SF_Array.Contains(pvValues, pvArgument, CaseSensitive := False) + End If + ' Check regular expression + If bValid And Len(pvRegex) > 0 And iVarType = V_STRING Then + If Len(pvArgument) > 0 Then bValid = SF_String.IsRegex(pvArgument, pvRegex, CaseSensitive := False) + End If + ' Check instance types + If bValid And Len(pvObjectType) > 0 And iVarType = V_OBJECT Then + 'Set oArgument = pvArgument + Set oObjectDescriptor = SF_Utils._VarTypeObj(pvArgument) + bValid = ( oObjectDescriptor.iVarType = V_SFOBJECT ) + If bValid Then bValid = ( oObjectDescriptor.sObjectType = pvObjectType ) + End If + End If + + If Not bValid Then + ''' Library: ScriptForge + ''' Service: Array + ''' Method: Contains + ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""] + ''' A serious error has been detected on argument SortOrder + ''' Rules: SortOrder is of type String + ''' SortOrder must contain one of next values: "ASC", "DESC", "" + ''' Actual value: "Ascending" + SF_Exception.RaiseFatal(ARGUMENTERROR _ + , SF_Utils._Repr(pvArgument, cstMaxLength), psName, SF_Utils._TypeNames(pvTypes) _ + , SF_Utils._ReprValues(pvValues, cstMaxValues), pvRegex, pvObjectType _ + ) + End If + +Finally: + _Validate = bValid + _SF_.StackLevel = _SF_.StackLevel - 1 + Exit Function +CatchMissing: + bValid = False + SF_Exception.RaiseFatal(MISSINGARGERROR, psName) + GoTo Finally +End Function ' ScriptForge.SF_Utils._Validate + +REM ----------------------------------------------------------------------------- +Public Function _ValidateArray(Optional ByRef pvArray As Variant _ + , ByVal psName As String _ + , Optional ByVal piDimensions As Integer _ + , Optional ByVal piType As Integer _ + , Optional ByVal pbNotNull As Boolean _ + ) As Boolean +''' Validate the (array) arguments set by user scripts +''' The arguments of the function define the validation rules +''' This function ignores non-arrays. Use _Validate instead +''' Args: +''' pvArray: the argument to (in)validate +''' psName: the documented name of the array (can be inserted in an error message) +''' piDimensions: the # of dimensions the array must have. 0 = Any (default) +''' piType: (default = -1, i.e. not applicable) +''' For 2D arrays, the 1st column is checked +''' 0 => all items must be any out of next types: string, date or numeric, +''' but homogeneously: all strings or all dates or all numeric +''' V_STRING or V_DATE or V_NUMERIC => that specific type is required +''' pbNotNull: piType must be >=0, otherwise ignored +''' If True: Empty, Null items are rejected +''' Return: True if validation OK +''' Otherwise an error is raised +''' Exceptions: +''' ARRAYERROR + +Dim iVarType As Integer ' VarType of argument +Dim vItem As Variant ' Array item +Dim iItemType As Integer ' VarType of individual items of argument +Dim iDims As Integer ' Number of dimensions of the argument +Dim bValid As Boolean ' Returned value +Dim iArrayType As Integer ' Static array type +Dim iFirstItemType As Integer ' Type of 1st non-null/empty item +Dim sType As String ' Allowed item types as a string +Dim i As Long +Const cstMaxLength = 256 ' Maximum length of readable value + + ' To avoid useless recursions, keep main function, only increase stack depth + + _SF_.StackLevel = _SF_.StackLevel + 1 + On Local Error GoTo Finally ' Do never interrupt + +Try: + bValid = True + If IsMissing(pvArray) Then GoTo CatchMissing + If IsMissing(piDimensions) Then piDimensions = 0 + If IsMissing(piType) Then piType = -1 + If IsMissing(pbNotNull) Then pbNotNull = False + iVarType = VarType(pvArray) + + ' Scalars NEVER pass validation + If iVarType < V_ARRAY Then + bValid = False + Else + ' Check dimensions + iDims = SF_Array.CountDims(pvArray) + If iDims > 2 Then bValid = False ' Only 1D and 2D arrays + If bValid And piDimensions > 0 Then + bValid = ( iDims = piDimensions Or (iDims = 0 And piDimensions = 1) ) ' Allow empty vectors + End If + ' Check VarType and Empty/Null status of the array items + If bValid And iDims = 1 And piType >= 0 Then + iArrayType = SF_Array._StaticType(pvArray) + If (piType = 0 And iArrayType > 0) Or (piType > 0 And iArrayType = piType) Then + ' If static array of the right VarType ..., OK + Else + ' Go through array and check individual items + iFirstItemType = -1 + For i = LBound(pvArray, 1) To UBound(pvArray, 1) + If iDims = 1 Then vItem = pvArray(i) Else vItem = pvArray(i, LBound(pvArray, 2)) + iItemType = SF_Utils._VarTypeExt(vItem) + If iItemType > V_NULL Then ' Exclude Empty and Null + ' Initialization at first non-null item + If iFirstItemType < 0 Then + iFirstItemType = iItemType + If piType > 0 Then bValid = ( iFirstItemType = piType ) Else bValid = SF_Array.Contains(Array(V_STRING, V_DATE, V_NUMERIC), iFirstItemType) + Else + bValid = (iItemType = iFirstItemType) + End If + Else + bValid = Not pbNotNull + End If + If Not bValid Then Exit For + Next i + End If + End If + End If + + If Not bValid Then + ''' Library: ScriptForge + ''' Service: Array + ''' Method: Contains + ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""|"ASC"|"DESC"] + ''' An error was detected on argument Array_1D + ''' Rules: Array_1D is of type Array + ''' Array_1D must have maximum 1 dimension + ''' Array_1D must have all elements of the same type: either String, Date or Numeric + ''' Actual value: (0:2, 0:3) + sType = "" + If piType = 0 Then + sType = "String, Date, Numeric" + ElseIf piType > 0 Then + sType = SF_Utils._TypeNames(piType) + End If + SF_Exception.RaiseFatal(ARRAYERROR _ + , SF_Utils._Repr(pvArray, cstMaxLength), psName, piDimensions, sType, pbNotNull) + End If + +Finally: + _ValidateArray = bValid + _SF_.StackLevel = _SF_.StackLevel - 1 + Exit Function +CatchMissing: + bValid = False + SF_Exception.RaiseFatal(MISSINGARGERROR, psName) + GoTo Finally +End Function ' ScriptForge.SF_Utils._ValidateArray + +REM ----------------------------------------------------------------------------- +Public Function _ValidateFile(Optional ByRef pvArgument As Variant _ + , ByVal psName As String _ + , Optional ByVal pbWildCards As Boolean _ + , Optional ByVal pbSpace As Boolean _ + ) +''' Validate the argument as a valid FileName +''' Args: +''' pvArgument: the argument to (in)validate +''' pbWildCards: if True, wildcard characters are accepted in the last component of the 1st argument +''' pbSpace: if True, the argument may be an empty string. Default = False +''' Return: True if validation OK +''' Otherwise an error is raised +''' Exceptions: +''' ARGUMENTERROR + +Dim iVarType As Integer ' VarType of argument +Dim sFile As String ' Alias for argument +Dim bValid As Boolean ' Returned value +Dim sFileNaming As String ' Alias of SF_FileSystem.FileNaming +Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement +Const cstMaxLength = 256 ' Maximum length of readable value + + ' To avoid useless recursions, keep main function, only increase stack depth + + _SF_.StackLevel = _SF_.StackLevel + 1 + On Local Error GoTo Finally ' Do never interrupt + +Try: + bValid = True + If IsMissing(pvArgument) Then GoTo CatchMissing + If IsMissing(pbWildCards) Then pbWildCards = False + If IsMissing(pbSpace) Then pbSpace = False + iVarType = VarType(pvArgument) + + ' Arrays NEVER pass validation + If iVarType >= V_ARRAY Then + bValid = False + Else + ' Argument must be a string containing a valid file name + bValid = ( iVarType = V_STRING ) + If bValid Then + bValid = ( Len(pvArgument) > 0 Or pbSpace ) + If bValid And Len(pvArgument) > 0 Then + ' Wildcards are replaced by arbitrary alpha characters + If pbWildCards Then + sFile = Replace(Replace(pvArgument, "?", "Z"), "*", "A") + Else + sFile = pvArgument + bValid = ( InStr(sFile, "?") + InStr(sFile, "*") = 0 ) + End If + ' Check file format without wildcards + If bValid Then + With SF_FileSystem + sFileNaming = .FileNaming + Select Case sFileNaming + Case "ANY" : bValid = SF_String.IsUrl(ConvertToUrl(sFile)) + Case "URL" : bValid = SF_String.IsUrl(sFile) + Case "SYS" : bValid = SF_String.IsFileName(sFile) + End Select + End With + End If + ' Check that wildcards are only present in last component + If bValid And pbWildCards Then + sFile = SF_FileSystem.GetParentFolderName(pvArgument) + bValid = ( InStr(sFile, "*") + InStr(sFile, "?") + InStr(sFile,"%3F") = 0 ) ' ConvertToUrl replaces ? by %3F + End If + End If + End If + End If + + If Not bValid Then + ''' Library: ScriptForge + ''' Service: FileSystem + ''' Method: CopyFile + ''' Arguments: Source, Destination + ''' A serious error has been detected on argument Source + ''' Rules: Source is of type String + ''' Source must be a valid file name expressed in operating system notation + ''' Source may contain one or more wildcard characters in its last component + ''' Actual value: /home/jean-*/SomeFile.odt + SF_Exception.RaiseFatal(FILEERROR _ + , SF_Utils._Repr(pvArgument, cstMaxLength), psName, pbWildCards) + End If + +Finally: + _ValidateFile = bValid + _SF_.StackLevel = _SF_.StackLevel - 1 + Exit Function +CatchMissing: + bValid = False + SF_Exception.RaiseFatal(MISSINGARGERROR, psName) + GoTo Finally +End Function ' ScriptForge.SF_Utils._ValidateFile + +REM ----------------------------------------------------------------------------- +Public Function _VarTypeExt(ByRef pvValue As Variant) As Integer +''' Return the VarType of the argument but all numeric types are aggregated into V_NUMERIC +''' Args: +''' pvValue: value to examine +''' Return: +''' The extended VarType + +Dim iType As Integer ' VarType of argument + + iType = VarType(pvValue) + Select Case iType + Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL + _VarTypeExt = V_NUMERIC + Case Else : _VarTypeExt = iType + End Select + +End Function ' ScriptForge.SF_Utils._VarTypeExt + +REM ----------------------------------------------------------------------------- +Public Function _VarTypeObj(ByRef pvValue As Variant) As Object +''' Inspect the argument that is supposed to be an Object +''' Return the internal type of object as one of the values +''' V_NOTHING Null object +''' V_UNOOBJECT Uno object or Uno structure +''' V_SFOBJECT ScriptForge object: has ObjectType and ServiceName properties +''' V_BASICOBJECT User Basic object +''' coupled with object type as a string ("com.sun.star..." or "SF_..." or "... ScriptForge class ...") +''' When the argument is not an Object, return the usual VarType() of the argument + +Dim oObjDesc As _ObjectDescriptor ' Return value +Dim oValue As Object ' Alias of pvValue used to avoid "Object variable not set" error +Dim sObjType As String ' The type of object is first derived as a string +Dim oReflection As Object ' com.sun.star.reflection.CoreReflection +Dim vClass As Variant ' com.sun.star.reflection.XIdlClass +Dim bUno As Boolean ' True when object recognized as UNO object + +Const cstBasicClass = "com.sun.star.script.NativeObjectWrapper" ' Way to recognize Basic objects + + On Local Error Resume Next ' Object type is established by trial and error + +Try: + With oObjDesc + .iVarType = VarType(pvValue) + .sObjectType = "" + .sServiceName = "" + bUno = False + If .iVarType = V_OBJECT Then + If IsNull(pvValue) Then + .iVarType = V_NOTHING + Else + Set oValue = pvValue + ' Try UNO type with usual ImplementationName property + .sObjectType = oValue.getImplementationName() + If .sObjectType = "" Then + ' Try UNO type with alternative CoreReflection trick + Set oReflection = SF_Utils._GetUNOService("CoreReflection") + vClass = oReflection.getType(oValue) + If vClass.TypeClass >= com.sun.star.uno.TypeClass.STRUCT Then + .sObjectType = vClass.Name + bUno = True + End If + Else + bUno = True + End If + ' Identify Basic objects + If .sObjectType = cstBasicClass Then + bUno = False + ' Try if the Basic object has an ObjectType property + .sObjectType = oValue.ObjectType + .sServiceName = oValue.ServiceName + End If + ' Derive the return value from the object type + Select Case True + Case Len(.sObjectType) = 0 ' Do nothing (return V_OBJECT) + Case .sObjectType = cstBasicClass : .iVarType = V_BASICOBJECT + Case bUno : .iVarType = V_UNOOBJECT + Case Else : .iVarType = V_SFOBJECT + End Select + End If + End If + End With + +Finally: + Set _VarTypeObj = oObjDesc + Exit Function +End Function ' ScriptForge.SF_Utils._VarTypeObj + +REM ================================================= END OF SCRIPTFORGE.SF_UTILS +</script:module>
\ No newline at end of file |