967 lines
42 KiB
Java
967 lines
42 KiB
Java
<?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.1"
|
|
|
|
''' 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
|
|
Global Const V_NUMERIC = 99 ' Fictive VarType synonym of any numeric value
|
|
|
|
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_
|
|
.Interface.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 -----------------------------------------------------------------------------
|
|
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 oConfigProvider As Object
|
|
Dim oDefaultContext As Object
|
|
Dim vNodePath As Variant
|
|
|
|
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 "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 "FunctionAccess"
|
|
If IsEmpty(.FunctionAccess) Or IsNull(.FunctionAccess) Then
|
|
Set .FunctionAccess = CreateUnoService("com.sun.star.sheet.FunctionAccess")
|
|
End If
|
|
Set _GetUNOService = .FunctionAccess
|
|
Case "Introspection"
|
|
If IsEmpty(.Introspection) Or IsNull(.Introspection) Then
|
|
Set .Introspection = CreateUnoService("com.sun.star.beans.Introspection")
|
|
End If
|
|
Set _GetUNOService = .Introspection
|
|
Case "Locale"
|
|
If IsEmpty(.Locale) Or IsNull(.Locale) Then
|
|
.Locale = CreateUnoStruct("com.sun.star.lang.Locale")
|
|
' Derived from the Tools library
|
|
Set oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
|
|
vNodePath = Array() : ReDim vNodePath(0)
|
|
vNodePath(0) = New com.sun.star.beans.PropertyValue
|
|
vNodePath(0).Name = "nodepath" : vNodePath(0).Value = "org.openoffice.Setup/L10N"
|
|
sLocale = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", vNodePath()).getByName("ooLocale")
|
|
.Locale.Language = Left(sLocale, 2)
|
|
.Locale.Country = Right(sLocale, 2)
|
|
End If
|
|
Set _GetUNOService = .Locale
|
|
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 "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 "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 "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 "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_
|
|
' Localization
|
|
_SF_._LoadLocalizedInterface()
|
|
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 sObject As String ' Object representation
|
|
Dim sObjectType As String ' ObjectType attribute of Basic objects
|
|
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) Or 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
|
|
If IsNull(pvArg) Then
|
|
sArg = "[NULL]"
|
|
Else
|
|
sObject = SF_Session.UnoObjectType(pvArg)
|
|
If sObject = "" Or sObject = cstBasicObject Then ' Not a UNO object
|
|
' Test if argument is a ScriptForge object
|
|
sObjectType = ""
|
|
On Local Error Resume Next
|
|
Set oObject = pvArg
|
|
sObjectType = oObject.ObjectType
|
|
On Error GoTo 0
|
|
If sObjectType = "" Then
|
|
sArg = "[OBJECT]"
|
|
ElseIf Left(sObjectType, 3) = "SF_" Then
|
|
sArg = "[" & sObjectType & "]"
|
|
Else
|
|
sArg = oObject._Repr()
|
|
End If
|
|
Else
|
|
sArg = "[" & sObject & "]"
|
|
End If
|
|
End If
|
|
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 Sub _SetPropertyValue(ByRef pvPropertyValue As Variant _
|
|
, ByVal psName As String _
|
|
, ByRef pvValue As Variant _
|
|
)
|
|
''' Update 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 array
|
|
|
|
Dim oPropertyValue As New com.sun.star.beans.PropertyValue
|
|
Dim lIndex As Long ' Found entry
|
|
Dim vValue As Variant ' Alias of pvValue
|
|
Dim i As Long
|
|
|
|
lIndex = -1
|
|
For i = 0 To UBound(pvPropertyValue)
|
|
If pvPropertyValue(i).Name = psName Then
|
|
lIndex = i
|
|
Exit For
|
|
End If
|
|
Next i
|
|
If lIndex < 0 Then ' Not found
|
|
lIndex = UBound(pvPropertyValue) + 1
|
|
ReDim Preserve pvPropertyValue(0 To lIndex)
|
|
Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue)
|
|
pvPropertyValue(lIndex) = oPropertyValue
|
|
Else ' psName exists already in array of property values
|
|
pvPropertyValue(lIndex).Value = SF_Utils._CPropertyValue(pvValue)
|
|
End If
|
|
|
|
End Sub ' 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 oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement
|
|
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
|
|
bValid = ( pvObjectType = oArgument.ObjectType )
|
|
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 ================================================= END OF SCRIPTFORGE.SF_UTILS
|
|
</script:module> |