2f9a4a80c0
All arguments passed to ScriptForge methods are checked for validity. A.o. a string may be compared with a closed list of allowed values. The comparison may now optionally be made with a CaseSentitive As Boolean parameter. All occurrences where this check makes sense were identified, inventoried and modified. A True argument has been inserted where appropriate. Change-Id: I1a5cb7fb42618bc83fc8ec57c2727fc2a1bfcdb9 Reviewed-on: https://gerrit.libreoffice.org/c/core/+/172530 Reviewed-by: Jean-Pierre Ledure <jp@ledure.be> Tested-by: Jenkins
1119 lines
No EOL
50 KiB
XML
1119 lines
No EOL
50 KiB
XML
<?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.2"
|
|
|
|
''' 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) 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 = ""
|
|
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"
|
|
Set .FilePicker = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") ' Do not reuse an existing FilePicker: TDF#154462
|
|
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 "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> |