Quellcode-Bibliothek SF_Utils.xba   Sprache: unbekannt

<?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 = "25.8"

''' 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 _
        , Optional ByVal pbReinitRC As Variant _
        ) As Boolean
''' 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 = ""
  If IsMissing(pbReinitRC) Then pbReinitRC = True
  With _SF_
   If .StackLevel = 0 Then
    .MainFunction = psSub
    .MainFunctionArgs = psArgs
    _EnterFunction = True
    If pbReinitRC Then
     ' Reinitialize return code status
     .ReturnCode = ""
     .ReturnCodeDescription = ""
    End If
   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 "FilterFactory"
    If IsEmpty(.FilterFactory) Or IsNull(.FilterFactory) Then
     Set .FilterFactory = CreateUnoService("com.sun.star.document.FilterFactory")
    End If
    Set _GetUNOService = .FilterFactory
   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 "ModuleUIConfigurationManagerSupplier"
    If IsEmpty(.ModuleUIConfigurationManagerSupplier) Or IsNull(.ModuleUIConfigurationManagerSupplier) Then
     Set .ModuleUIConfigurationManagerSupplier = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier")
    End If
    Set _GetUNOService = .ModuleUIConfigurationManagerSupplier
   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 "TransientDocumentFactory"
    If IsEmpty(.TransientDocument) Or IsNull(.TransientDocument) Then
     Set .TransientDocument = CreateUnoService("com.sun.star.frame.TransientDocumentsDocumentContentFactory")
    End If
    Set _GetUNOService = .TransientDocument
   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 pvCaseSensitive 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
'''  pvCaseSensitive: when True the comparison between strings is done case-sensitively
'''  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(pvCaseSensitive) Or IsEmpty(pvCaseSensitive) Then pvCaseSensitive = False
 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 := pvCaseSensitive)
  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), pvCaseSensitive, 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
Const DOCFILESYSTEM = "vnd.sun.star.tdoc:/"

 ' 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
      If SF_String.StartsWith(sFile, DOCFILESYSTEM) Then sFileNaming = "URL"
      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>