| blob | 11753704c4617e5844b566ac5cb93c8b4815998a |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Utils" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === Full documentation is available on https://help.libreoffice.org/ ===
6 REM =======================================================================================================================
8 Option Explicit
9 Option Private Module
11 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
12 ''' SF_Utils
13 ''' ========
14 ''' FOR INTERNAL USE ONLY
15 ''' Groups all private functions used by the official modules
16 ''' Declares the Global variable _SF_
17 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
19 REM ===================================================================== GLOBALS
21 Global _SF_ As Variant ' SF_Root (Basic) object)
23 ''' ScriptForge version
26 ''' Standard symbolic names for VarTypes
36 ''' Additional symbolic names for VarTypes
37 Global Const V_OBJECT = 9
38 Global Const V_BOOLEAN = 11
39 Global Const V_VARIANT = 12
40 Global Const V_BYTE = 17
41 Global Const V_USHORT = 18
42 Global Const V_ULONG = 19
43 Global Const V_BIGINT = 35
44 Global Const V_DECIMAL = 37
45 Global Const V_ARRAY = 8192
46 ''' Fictive VarTypes
50 Global Const V_SFOBJECT = 103 ' ScriptForge object: has ObjectType and ServiceName properties
53 Type _ObjectDescriptor ' Returned by the _VarTypeObj() method
54 iVarType As Integer ' One of the V_NOTHING, V_xxxOBJECT constants
55 sObjectType As String ' Either "" or "com.sun.star..." or a ScriptForge object type (ex. "SF_SESSION" or "DICTIONARY")
56 sServiceName As String ' Either "" or the service name of a ScriptForge object type (ex. "ScriptForge.Exception"-
57 End Type
59 REM ================================================================== EXCEPTIONS
62 Const ARGUMENTERROR = "ARGUMENTERROR" ' An argument does not pass the _Validate() validation
63 Const ARRAYERROR = "ARRAYERROR" ' An argument does not pass the _ValidateArray() validation
64 Const FILEERROR = "FILEERROR" ' An argument does not pass the _ValidateFile() validation
66 REM =========================================pvA==================== PRIVATE METHODS
68 REM -----------------------------------------------------------------------------
69 Public Function _CDateToIso(pvDate As Variant) As Variant
70 ''' Returns a string representation of the given Basic date
71 ''' Dates as strings are essential in property values, where Basic dates are evil
73 Dim sIsoDate As Variant ' Return value
75 If VarType(pvDate) = V_DATE Then
77 sIsoDate = Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) & ":" & Right("0" & Second(pvDate), 2)
79 sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2)
80 Else
81 sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2) _
82 & " " & Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) _
84 End If
85 Else
86 sIsoDate = pvDate
87 End If
89 _CDateToIso = sIsoDate
91 End Function ' ScriptForge.SF_Utils._CDateToIso
93 REM -----------------------------------------------------------------------------
94 Public Function _CDateToUnoDate(pvDate As Variant) As Variant
95 ''' Returns a UNO com.sun.star.util.DateTime/Date/Time object depending on the given date
96 ''' by using the appropriate CDateToUnoDateXxx builtin function
97 ''' UNO dates are essential in property values, where Basic dates are evil
99 Dim vUnoDate As Variant ' Return value
101 If VarType(pvDate) = V_DATE Then
103 vUnoDate = CDateToUnoTime(pvDate)
104 ElseIf Hour(pvDate) + Minute(pvDate) + Second(pvDate) = 0 Then
105 vUnoDate = CDateToUnoDate(pvDate)
106 Else
107 vUnoDate = CDateToUnoDateTime(pvDate)
108 End If
109 Else
110 vUnoDate = pvDate
111 End If
113 _CDateToUnoDate = vUnoDate
115 End Function ' ScriptForge.SF_Utils._CDateToUnoDate
117 REM -----------------------------------------------------------------------------
118 Public Function _CPropertyValue(ByRef pvValue As Variant) As Variant
119 ''' Set a value of a correct type in a com.sun.star.beans.PropertyValue
120 ''' Date BASIC variables give error. Change them to UNO types
121 ''' Empty arrays should be replaced by Null
123 Dim vValue As Variant ' Return value
125 If VarType(pvValue) = V_DATE Then
126 vValue = SF_Utils._CDateToUnoDate(pvValue)
127 ElseIf IsArray(pvValue) Then
129 Else
130 vValue = pvValue
131 End If
132 _CPropertyValue() = vValue
134 End Function ' ScriptForge.SF_Utils._CPropertyValue
136 REM -----------------------------------------------------------------------------
137 Public Function _CStrToDate(ByRef pvStr As String) As Date
138 ''' Attempt to convert the input string to a Date variable with the CDate builtin function
140 ''' Date patterns: YYYY-MM-DD, HH:MM:DD and YYYY-MM-DD HH:MM:DD
142 Dim dDate As Date ' Return value
143 Const cstNoDate = -1
145 dDate = cstNoDate
146 Try:
147 On Local Error Resume Next
148 dDate = CDate(pvStr)
150 Finally:
151 _CStrToDate = dDate
152 Exit Function
153 End Function ' ScriptForge.SF_Utils._CStrToDate
155 REM -----------------------------------------------------------------------------
156 Public Function _EnterFunction(ByVal psSub As String, Optional ByVal psArgs As String) As Boolean
157 ''' Called on top of each public function
158 ''' Used to trace routine in/outs (debug mode)
159 ''' and to allow the explicit mention of the user call which caused an error
160 ''' Args:
161 ''' psSub = the called Sub/Function/Property, usually something like "service.sub"
162 ''' Return: True when psSub is called from a user script
163 ''' Used to bypass the validation of the arguments when unnecessary
165 If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session
166 If IsMissing(psArgs) Then psArgs = ""
167 With _SF_
168 If .StackLevel = 0 Then
169 .MainFunction = psSub
170 .MainFunctionArgs = psArgs
171 _EnterFunction = True
172 Else
173 _EnterFunction = False
174 End If
175 .StackLevel = .StackLevel + 1
176 If .DebugMode Then ._AddToConsole("==> " & psSub & "(" & .StackLevel & ")")
177 End With
179 End Function ' ScriptForge.SF_Utils._EnterFunction
181 REM -----------------------------------------------------------------------------
182 Public Function _ErrorHandling(Optional ByVal pbErrorHandler As Boolean) As Boolean
183 ''' Error handling is normally ON and can be set OFF for debugging purposes
184 ''' Each user visible routine starts with a call to this function to enable/disable
185 ''' standard handling of internal errors
186 ''' Args:
187 ''' pbErrorHandler = if present, set its value
188 ''' Return: the current value of the error handler
190 If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session
191 If Not IsMissing(pbErrorHandler) Then _SF_.ErrorHandler = pbErrorHandler
192 _ErrorHandling = _SF_.ErrorHandler
194 End Function ' ScriptForge.SF_Utils._ErrorHandling
196 REM -----------------------------------------------------------------------------
197 Public Sub _ExitFunction(ByVal psSub As String)
198 ''' Called in the Finally block of each public function
199 ''' Manage ScriptForge internal aborts
200 ''' Resets MainFunction (root) when exiting the method called by a user script
201 ''' Used to trace routine in/outs (debug mode)
202 ''' Args:
203 ''' psSub = the called Sub/Function/Property, usually something like "service.sub"
205 If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' Useful only when current module has been recompiled
206 With _SF_
208 SF_Exception.RaiseAbort(psSub)
209 End If
210 If .StackLevel = 1 Then
211 .MainFunction = ""
212 .MainFunctionArgs = ""
213 End If
214 If .DebugMode Then ._AddToConsole("<== " & psSub & "(" & .StackLevel & ")")
216 End With
218 End Sub ' ScriptForge.SF_Utils._ExitFunction
220 REM -----------------------------------------------------------------------------
221 Public Sub _ExportScriptForgePOTFile(ByVal FileName As String)
222 ''' Export the ScriptForge POT file related to its own user interface
223 ''' Should be called only before issuing new ScriptForge releases only
224 ''' Args:
225 ''' FileName: the resulting file. If it exists, is overwritten without warning
227 Dim sHeader As String ' The specific header to insert
229 sHeader = "" _
238 Try:
239 With _SF_
240 If Not IsNull(.LocalizedInterface) Then .LocalizedInterface.Dispose()
241 ._LoadLocalizedInterface(psMode := "ADDTEXT") ' Force reload of labels from the code
242 .LocalizedInterface.ExportToPOTFile(FileName, Header := sHeader)
243 End With
245 Finally:
246 Exit Sub
247 End Sub ' ScriptForge.SF_Utils._ExportScriptForgePOTFile
249 REM -----------------------------------------------------------------------------
250 Public Function _GetPropertyValue(ByRef pvArgs As Variant, ByVal psName As String) As Variant
251 ''' Returns the Value corresponding to the given name
252 ''' Args
253 ''' pvArgs: a zero_based array of PropertyValues
254 ''' psName: the comparison is not case-sensitive
255 ''' Returns:
256 ''' Zero-length string if not found
258 Dim vValue As Variant ' Return value
259 Dim i As Long
261 vValue = ""
262 If IsArray(pvArgs) Then
263 For i = LBound(pvArgs) To UBound(pvArgs)
264 If UCase(psName) = UCase(pvArgs(i).Name) Then
265 vValue = pvArgs(i).Value
266 Exit For
267 End If
268 Next i
269 End If
270 _GetPropertyValue = vValue
272 End Function ' ScriptForge.SF_Utils._GetPropertyValue
274 REM -----------------------------------------------------------------------------
275 Public Function _GetRegistryKeyContent(ByVal psKeyName as string _
276 , Optional pbForUpdate as Boolean _
277 ) As Variant
278 ''' Implement a ConfigurationProvider service
279 ''' Derived from the Tools library
280 ''' Args:
281 ''' psKeyName: the name of the node in the configuration tree
282 ''' pbForUpdate: default = False
284 Dim oConfigProvider as Object ' com.sun.star.configuration.ConfigurationProvider
285 Dim vNodePath(0) as New com.sun.star.beans.PropertyValue
292 vNodePath(0).Value = psKeyName
294 If IsMissing(pbForUpdate) Then pbForUpdate = False
295 If pbForUpdate Then sConfig = cstConfigUpdate Else sConfig = cstConfig
297 Set _GetRegistryKeyContent = oConfigProvider.createInstanceWithArguments(sConfig, vNodePath())
299 End Function ' ScriptForge.SF_Utils._GetRegistryKeyContent
301 REM -----------------------------------------------------------------------------
302 Private Function _GetSetting(ByVal psPreference As String, psProperty As String) As Variant
303 ''' Find in the configuration a specific setting based on its location in the
304 ''' settings registry
306 Dim oConfigProvider As Object ' com.sun.star.configuration.ConfigurationProvider
307 Dim vNodePath As Variant ' Array of com.sun.star.beans.PropertyValue
309 ' Derived from the Tools library
310 Set oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
313 _GetSetting = oConfigProvider.createInstanceWithArguments( _
316 End Function ' ScriptForge.SF_Utils._GetSetting
318 REM -----------------------------------------------------------------------------
319 Public Function _GetUNOService(ByVal psService As String _
320 , Optional ByVal pvArg As Variant _
321 ) As Object
322 ''' Create a UNO service
323 ''' Each service is called only once
324 ''' Args:
325 ''' psService: shortcut to service
326 ''' pvArg: some services might require an argument
328 Dim sLocale As String ' fr-BE f.i.
329 Dim oDefaultContext As Object
331 Set _GetUNOService = Nothing
332 With _SF_
333 Select Case psService
335 Set oDefaultContext = GetDefaultContext()
336 If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.script.browse.theBrowseNodeFactory")
338 If IsEmpty(.CalendarImpl) Or IsNull(.CalendarImpl) Then
340 End If
341 Set _GetUNOService = .CalendarImpl
343 If IsEmpty(.CharacterClass) Or IsNull(.CharacterClass) Then
345 End If
346 Set _GetUNOService = .CharacterClass
348 If IsEmpty(.ConfigurationProvider) Or IsNull(.ConfigurationProvider) Then
349 Set .ConfigurationProvider = CreateUnoService("com.sun.star.configuration.ConfigurationProvider")
350 End If
351 Set _GetUNOService = .ConfigurationProvider
353 If IsEmpty(.CoreReflection) Or IsNull(.CoreReflection) Then
355 End If
356 Set _GetUNOService = .CoreReflection
358 If IsEmpty(.DatabaseContext) Or IsNull(.DatabaseContext) Then
360 End If
361 Set _GetUNOService = .DatabaseContext
363 If IsEmpty(.DispatchHelper) Or IsNull(.DispatchHelper) Then
365 End If
366 Set _GetUNOService = .DispatchHelper
368 If IsEmpty(.FileAccess) Or IsNull(.FileAccess) Then
370 End If
371 Set _GetUNOService = .FileAccess
373 Set .FilePicker = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") ' Do not reuse an existing FilePicker: TDF#154462
374 Set _GetUNOService = .FilePicker
376 If IsEmpty(.FilterFactory) Or IsNull(.FilterFactory) Then
378 End If
379 Set _GetUNOService = .FilterFactory
381 If IsEmpty(.FolderPicker) Or IsNull(.FolderPicker) Then
383 End If
384 Set _GetUNOService = .FolderPicker
386 If IsEmpty(.FormatLocale) Or IsNull(.FormatLocale) Then
389 sLocale = SF_Utils._GetSetting("org.openoffice.Setup/L10N", "ooSetupSystemLocale")
390 If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale")
391 .FormatLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always
392 .FormatLocale.Country = Right(sLocale, 2)
393 End If
394 Set _GetUNOService = .FormatLocale
396 If IsEmpty(.FunctionAccess) Or IsNull(.FunctionAccess) Then
398 End If
399 Set _GetUNOService = .FunctionAccess
401 If IsEmpty(.GraphicExportFilter) Or IsNull(.GraphicExportFilter) Then
402 Set .GraphicExportFilter = CreateUnoService("com.sun.star.drawing.GraphicExportFilter")
403 End If
404 Set _GetUNOService = .GraphicExportFilter
406 If IsEmpty(.Introspection) Or IsNull(.Introspection) Then
408 End If
409 Set _GetUNOService = .Introspection
411 If IsEmpty(.LocaleData) Or IsNull(.LocaleData) Then
413 End If
414 Set _GetUNOService = .LocaleData
416 Set oDefaultContext = GetDefaultContext()
417 If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.util.theMacroExpander")
419 If IsEmpty(.MailService) Or IsNull(.MailService) Then
422 Else
424 End If
425 End If
426 Set _GetUNOService = .MailService
428 If IsEmpty(.ModuleUIConfigurationManagerSupplier) Or IsNull(.ModuleUIConfigurationManagerSupplier) Then
429 Set .ModuleUIConfigurationManagerSupplier = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier")
430 End If
431 Set _GetUNOService = .ModuleUIConfigurationManagerSupplier
433 If IsEmpty(.Number2Text) Or IsNull(.Number2Text) Then
435 End If
436 Set _GetUNOService = .Number2Text
438 If IsEmpty(.OfficeLocale) Or IsNull(.OfficeLocale) Then
442 If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale")
443 .OfficeLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always
444 .OfficeLocale.Country = Right(sLocale, 2)
445 End If
446 Set _GetUNOService = .OfficeLocale
448 If IsEmpty(.PackageProvider) Or IsNull(.PackageProvider) Then
449 Set .PackageProvider = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider")
450 End If
451 Set _GetUNOService = .PackageProvider
453 If IsEmpty(.PathSettings) Or IsNull(.PathSettings) Then
455 End If
456 Set _GetUNOService = .PathSettings
458 If IsEmpty(.PathSubstitution) Or IsNull(.PathSubstitution) Then
460 End If
461 Set _GetUNOService = .PathSubstitution
463 If IsEmpty(.PrinterServer) Or IsNull(.PrinterServer) Then
465 End If
466 Set _GetUNOService = .PrinterServer
468 If IsMissing(pvArg) Then pvArg = SF_Session.SCRIPTISAPPLICATION
469 Select Case LCase(pvArg)
470 Case SF_Session.SCRIPTISEMBEDDED ' Document
471 If Not IsNull(ThisComponent) Then Set _GetUNOService = ThisComponent.getScriptProvider()
472 Case Else
473 If IsEmpty(.ScriptProvider) Or IsNull(.ScriptProvider) Then
474 Set .ScriptProvider = _
475 CreateUnoService("com.sun.star.script.provider.MasterScriptProviderFactory").createScriptProvider("")
476 End If
477 Set _GetUNOService = .ScriptProvider
478 End Select
480 If IsEmpty(.SearchOptions) Or IsNull(.SearchOptions) Then
481 Set .SearchOptions = New com.sun.star.util.SearchOptions
482 With .SearchOptions
483 .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
484 .searchFlag = 0
485 End With
486 End If
487 Set _GetUNOService = .SearchOptions
489 If IsEmpty(.SystemLocale) Or IsNull(.SystemLocale) Then
491 sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "SystemLocale")
492 .SystemLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always
493 .SystemLocale.Country = Right(sLocale, 2)
494 End If
495 Set _GetUNOService = .SystemLocale
497 If IsEmpty(.SystemShellExecute) Or IsNull(.SystemShellExecute) Then
499 End If
500 Set _GetUNOService = .SystemShellExecute
502 If IsEmpty(.TextSearch) Or IsNull(.TextSearch) Then
504 End If
505 Set _GetUNOService = .TextSearch
507 If IsEmpty(.Toolkit) Or IsNull(.Toolkit) Then
509 End If
510 Set _GetUNOService = .Toolkit
512 If IsEmpty(.URLTransformer) Or IsNull(.URLTransformer) Then
514 End If
515 Set _GetUNOService = .URLTransformer
516 Case Else
517 End Select
518 End With
520 End Function ' ScriptForge.SF_Utils._GetUNOService
522 REM -----------------------------------------------------------------------------
523 Public Sub _InitializeRoot(Optional ByVal pbForce As Boolean)
524 ''' Initialize _SF_ as SF_Root basic object
525 ''' Args:
526 ''' pbForce = True forces the reinit (default = False)
528 If IsMissing(pbForce) Then pbForce = False
529 If pbForce Then Set _SF_ = Nothing
530 If IsEmpty(_SF_) Or IsNull(_SF_) Then
531 Set _SF_ = New SF_Root
532 Set _SF_.[Me] = _SF_
533 End If
535 End Sub ' ScriptForge.SF_Utils._InitializeRoot
537 REM -----------------------------------------------------------------------------
538 Public Function _MakePropertyValue(ByVal psName As String _
539 , ByRef pvValue As Variant _
540 ) As com.sun.star.beans.PropertyValue
541 ''' Create and return a new com.sun.star.beans.PropertyValue
543 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
545 With oPropertyValue
546 .Name = psName
547 .Value = SF_Utils._CPropertyValue(pvValue)
548 End With
549 _MakePropertyValue() = oPropertyValue
551 End Function ' ScriptForge.SF_Utils._MakePropertyValue
553 REM -----------------------------------------------------------------------------
554 Public Function _Repr(ByVal pvArg As Variant, Optional ByVal plMax As Long) As String
556 ''' Args
557 ''' pvArg: may be of any type
560 Dim sArg As String ' Return value
562 Dim oObjectDesc As Object ' Object descriptor
563 Dim sLength As String ' String length as a string
564 Dim i As Long
568 Const cstByteLength = 25
571 If IsMissing(plMax) Then plMax = cstMaxLength
572 If plMax = 0 Then plMax = cstMaxLength
573 If IsArray(pvArg) Then
574 sArg = SF_Array._Repr(pvArg)
575 Else
576 Select Case VarType(pvArg)
579 Case V_OBJECT
580 Set oObjectDesc = SF_Utils._VarTypeObj(pvArg)
581 With oObjectDesc
582 Select Case .iVarType
584 Case V_OBJECT, V_BASICOBJECT
587 Case V_SFOBJECT
590 Else ' Class module must have a _Repr() method
591 Set oObject = pvArg
592 sArg = oObject._Repr()
593 End If
594 End Select
595 End With
597 Case V_STRING
598 sArg = SF_String._Repr(pvArg)
601 Case V_SINGLE, V_DOUBLE, V_CURRENCY
602 sArg = Format(pvArg)
605 Case V_BIGINT : sArg = CStr(CLng(pvArg))
606 Case V_DATE : sArg = _CDateToIso(pvArg)
607 Case Else : sArg = CStr(pvArg)
608 End Select
609 End If
610 If Len(sArg) > plMax Then
613 End If
614 _Repr = sArg
616 End Function ' ScriptForge.SF_Utils._Repr
618 REM -----------------------------------------------------------------------------
619 Private Function _ReprValues(Optional ByVal pvArgs As Variant _
620 , Optional ByVal plMax As Long _
621 ) As String
622 ''' Convert an array of values to a comma-separated list of readable strings
624 Dim sValues As String ' Return value
625 Dim sValue As String ' A single value
626 Dim vValue As Variant ' A single item in the argument
627 Dim i As Long ' Items counter
631 _ReprValues = ""
632 If IsMissing(pvArgs) Then Exit Function
633 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
634 sValues = ""
635 For i = 0 To UBound(pvArgs)
636 vValue = pvArgs(i)
637 If i < plMax Then
638 If VarType(vValue) = V_STRING Then sValue = """" & vValue & """" Else sValue = SF_Utils._Repr(vValue, cstMax)
639 If Len(sValues) = 0 Then sValues = sValue Else sValues = sValues & ", " & sValue
640 ElseIf i < UBound(pvArgs) Then
642 Exit For
643 End If
644 Next i
645 _ReprValues = sValues
647 End Function ' ScriptForge.SF_Utils._ReprValues
649 REM -----------------------------------------------------------------------------
650 Public Function _SetPropertyValue(ByVal pvPropertyValue As Variant _
651 , ByVal psName As String _
652 , ByRef pvValue As Variant _
653 ) As Variant
654 ''' Return the 1st argument (passed by reference), which is an array of property values
655 ''' If the property psName exists, update it with pvValue, otherwise create it on top of the returned array
657 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
658 Dim lIndex As Long ' Found entry
659 Dim vValue As Variant ' Alias of pvValue
660 Dim vProperties As Variant ' Alias of pvPropertyValue
661 Dim i As Long
663 lIndex = -1
664 vProperties = pvPropertyValue
665 For i = 0 To UBound(vProperties)
666 If vProperties(i).Name = psName Then
667 lIndex = i
668 Exit For
669 End If
670 Next i
672 lIndex = UBound(vProperties) + 1
673 ReDim Preserve vProperties(0 To lIndex)
674 Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue)
675 vProperties(lIndex) = oPropertyValue
676 vProperties = vProperties
677 Else ' psName exists already in array of property values
678 vProperties(lIndex).Value = SF_Utils._CPropertyValue(pvValue)
679 End If
681 _SetPropertyValue = vProperties
683 End Function ' ScriptForge.SF_Utils._SetPropertyValue
685 REM -----------------------------------------------------------------------------
686 Private Function _TypeNames(Optional ByVal pvArgs As Variant) As String
687 ''' Converts the array of VarTypes to a comma-separated list of TypeNames
689 Dim sTypes As String ' Return value
690 Dim sType As String ' A single type
691 Dim iType As Integer ' A single item of the argument
693 _TypeNames = ""
694 If IsMissing(pvArgs) Then Exit Function
695 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
696 sTypes = ""
697 For Each iType In pvArgs
698 Select Case iType
714 End Select
716 Next iType
717 _TypeNames = sTypes
719 End Function ' ScriptForge.SF_Utils._TypeNames
721 REM -----------------------------------------------------------------------------
722 Public Function _Validate(Optional ByRef pvArgument As Variant _
723 , ByVal psName As String _
724 , Optional ByVal pvTypes As Variant _
725 , Optional ByVal pvValues As Variant _
726 , Optional ByVal pvRegex As Variant _
727 , Optional ByVal pvObjectType As Variant _
728 ) As Boolean
729 ''' Validate the arguments set by user scripts
730 ''' The arguments of the function define the validation rules
731 ''' This function ignores arrays. Use _ValidateArray instead
732 ''' Args:
733 ''' pvArgument: the argument to (in)validate
734 ''' psName: the documented name of the argument (can be inserted in an error message)
735 ''' pvTypes: array of allowed VarTypes
736 ''' pvValues: array of allowed values
737 ''' pvRegex: regular expression to comply with
738 ''' pvObjectType: mandatory Basic class
739 ''' Return: True if validation OK
740 ''' Otherwise an error is raised
741 ''' Exceptions:
742 ''' ARGUMENTERROR
744 Dim iVarType As Integer ' Extended VarType of argument
745 Dim bValid As Boolean ' Returned value
746 Dim oObjectDescriptor As Object ' _ObjectDescriptor type
750 ' To avoid useless recursions, keep main function, only increase stack depth
751 _SF_.StackLevel = _SF_.StackLevel + 1
752 On Local Error GoTo Finally ' Do never interrupt
754 Try:
755 bValid = True
756 If IsMissing(pvArgument) Then GoTo CatchMissing
757 If IsMissing(pvRegex) Or IsEmpty(pvRegex) Then pvRegex = ""
758 If IsMissing(pvObjectType) Or IsEmpty(pvObjectType) Then pvObjectType = ""
759 iVarType = SF_Utils._VarTypeExt(pvArgument)
761 ' Arrays NEVER pass validation
762 If iVarType >= V_ARRAY Then
763 bValid = False
764 Else
765 ' Check existence of argument
768 If bValid And Not IsMissing(pvTypes) Then
769 If Not IsArray(pvTypes) Then bValid = ( pvTypes = iVarType ) Else bValid = SF_Array.Contains(pvTypes, iVarType)
770 End If
772 If bValid And Not IsMissing(pvValues) Then
773 If Not IsArray(pvValues) Then pvValues = Array(pvValues)
774 bValid = SF_Array.Contains(pvValues, pvArgument, CaseSensitive := False)
775 End If
776 ' Check regular expression
778 If Len(pvArgument) > 0 Then bValid = SF_String.IsRegex(pvArgument, pvRegex, CaseSensitive := False)
779 End If
780 ' Check instance types
782 'Set oArgument = pvArgument
783 Set oObjectDescriptor = SF_Utils._VarTypeObj(pvArgument)
784 bValid = ( oObjectDescriptor.iVarType = V_SFOBJECT )
785 If bValid Then bValid = ( oObjectDescriptor.sObjectType = pvObjectType )
786 End If
787 End If
789 If Not bValid Then
790 ''' Library: ScriptForge
791 ''' Service: Array
792 ''' Method: Contains
794 ''' A serious error has been detected on argument SortOrder
795 ''' Rules: SortOrder is of type String
796 ''' SortOrder must contain one of next values: "ASC", "DESC", ""
798 SF_Exception.RaiseFatal(ARGUMENTERROR _
799 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, SF_Utils._TypeNames(pvTypes) _
800 , SF_Utils._ReprValues(pvValues, cstMaxValues), pvRegex, pvObjectType _
801 )
802 End If
804 Finally:
805 _Validate = bValid
806 _SF_.StackLevel = _SF_.StackLevel - 1
807 Exit Function
808 CatchMissing:
809 bValid = False
810 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
811 GoTo Finally
812 End Function ' ScriptForge.SF_Utils._Validate
814 REM -----------------------------------------------------------------------------
815 Public Function _ValidateArray(Optional ByRef pvArray As Variant _
816 , ByVal psName As String _
817 , Optional ByVal piDimensions As Integer _
818 , Optional ByVal piType As Integer _
819 , Optional ByVal pbNotNull As Boolean _
820 ) As Boolean
821 ''' Validate the (array) arguments set by user scripts
822 ''' The arguments of the function define the validation rules
823 ''' This function ignores non-arrays. Use _Validate instead
824 ''' Args:
825 ''' pvArray: the argument to (in)validate
826 ''' psName: the documented name of the array (can be inserted in an error message)
831 ''' but homogeneously: all strings or all dates or all numeric
834 ''' If True: Empty, Null items are rejected
835 ''' Return: True if validation OK
836 ''' Otherwise an error is raised
837 ''' Exceptions:
838 ''' ARRAYERROR
840 Dim iVarType As Integer ' VarType of argument
841 Dim vItem As Variant ' Array item
842 Dim iItemType As Integer ' VarType of individual items of argument
843 Dim iDims As Integer ' Number of dimensions of the argument
844 Dim bValid As Boolean ' Returned value
845 Dim iArrayType As Integer ' Static array type
847 Dim sType As String ' Allowed item types as a string
848 Dim i As Long
851 ' To avoid useless recursions, keep main function, only increase stack depth
853 _SF_.StackLevel = _SF_.StackLevel + 1
854 On Local Error GoTo Finally ' Do never interrupt
856 Try:
857 bValid = True
858 If IsMissing(pvArray) Then GoTo CatchMissing
859 If IsMissing(piDimensions) Then piDimensions = 0
860 If IsMissing(piType) Then piType = -1
861 If IsMissing(pbNotNull) Then pbNotNull = False
862 iVarType = VarType(pvArray)
864 ' Scalars NEVER pass validation
865 If iVarType < V_ARRAY Then
866 bValid = False
867 Else
868 ' Check dimensions
869 iDims = SF_Array.CountDims(pvArray)
872 bValid = ( iDims = piDimensions Or (iDims = 0 And piDimensions = 1) ) ' Allow empty vectors
873 End If
874 ' Check VarType and Empty/Null status of the array items
876 iArrayType = SF_Array._StaticType(pvArray)
878 ' If static array of the right VarType ..., OK
879 Else
880 ' Go through array and check individual items
881 iFirstItemType = -1
884 iItemType = SF_Utils._VarTypeExt(vItem)
886 ' Initialization at first non-null item
888 iFirstItemType = iItemType
889 If piType > 0 Then bValid = ( iFirstItemType = piType ) Else bValid = SF_Array.Contains(Array(V_STRING, V_DATE, V_NUMERIC), iFirstItemType)
890 Else
891 bValid = (iItemType = iFirstItemType)
892 End If
893 Else
894 bValid = Not pbNotNull
895 End If
896 If Not bValid Then Exit For
897 Next i
898 End If
899 End If
900 End If
902 If Not bValid Then
903 ''' Library: ScriptForge
904 ''' Service: Array
905 ''' Method: Contains
906 ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""|"ASC"|"DESC"]
907 ''' An error was detected on argument Array_1D
908 ''' Rules: Array_1D is of type Array
910 ''' Array_1D must have all elements of the same type: either String, Date or Numeric
912 sType = ""
913 If piType = 0 Then
916 sType = SF_Utils._TypeNames(piType)
917 End If
918 SF_Exception.RaiseFatal(ARRAYERROR _
919 , SF_Utils._Repr(pvArray, cstMaxLength), psName, piDimensions, sType, pbNotNull)
920 End If
922 Finally:
923 _ValidateArray = bValid
924 _SF_.StackLevel = _SF_.StackLevel - 1
925 Exit Function
926 CatchMissing:
927 bValid = False
928 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
929 GoTo Finally
930 End Function ' ScriptForge.SF_Utils._ValidateArray
932 REM -----------------------------------------------------------------------------
933 Public Function _ValidateFile(Optional ByRef pvArgument As Variant _
934 , ByVal psName As String _
935 , Optional ByVal pbWildCards As Boolean _
936 , Optional ByVal pbSpace As Boolean _
937 )
938 ''' Validate the argument as a valid FileName
939 ''' Args:
940 ''' pvArgument: the argument to (in)validate
941 ''' pbWildCards: if True, wildcard characters are accepted in the last component of the 1st argument
942 ''' pbSpace: if True, the argument may be an empty string. Default = False
943 ''' Return: True if validation OK
944 ''' Otherwise an error is raised
945 ''' Exceptions:
946 ''' ARGUMENTERROR
948 Dim iVarType As Integer ' VarType of argument
949 Dim sFile As String ' Alias for argument
950 Dim bValid As Boolean ' Returned value
951 Dim sFileNaming As String ' Alias of SF_FileSystem.FileNaming
952 Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement
955 ' To avoid useless recursions, keep main function, only increase stack depth
957 _SF_.StackLevel = _SF_.StackLevel + 1
958 On Local Error GoTo Finally ' Do never interrupt
960 Try:
961 bValid = True
962 If IsMissing(pvArgument) Then GoTo CatchMissing
963 If IsMissing(pbWildCards) Then pbWildCards = False
964 If IsMissing(pbSpace) Then pbSpace = False
965 iVarType = VarType(pvArgument)
967 ' Arrays NEVER pass validation
968 If iVarType >= V_ARRAY Then
969 bValid = False
970 Else
971 ' Argument must be a string containing a valid file name
972 bValid = ( iVarType = V_STRING )
973 If bValid Then
976 ' Wildcards are replaced by arbitrary alpha characters
977 If pbWildCards Then
978 sFile = Replace(Replace(pvArgument, "?", "Z"), "*", "A")
979 Else
980 sFile = pvArgument
982 End If
983 ' Check file format without wildcards
984 If bValid Then
985 With SF_FileSystem
986 sFileNaming = .FileNaming
987 Select Case sFileNaming
991 End Select
992 End With
993 End If
994 ' Check that wildcards are only present in last component
995 If bValid And pbWildCards Then
996 sFile = SF_FileSystem.GetParentFolderName(pvArgument)
997 bValid = ( InStr(sFile, "*") + InStr(sFile, "?") + InStr(sFile,"%3F") = 0 ) ' ConvertToUrl replaces ? by %3F
998 End If
999 End If
1000 End If
1001 End If
1003 If Not bValid Then
1004 ''' Library: ScriptForge
1005 ''' Service: FileSystem
1006 ''' Method: CopyFile
1007 ''' Arguments: Source, Destination
1008 ''' A serious error has been detected on argument Source
1009 ''' Rules: Source is of type String
1010 ''' Source must be a valid file name expressed in operating system notation
1011 ''' Source may contain one or more wildcard characters in its last component
1012 ''' Actual value: /home/jean-*/SomeFile.odt
1013 SF_Exception.RaiseFatal(FILEERROR _
1014 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, pbWildCards)
1015 End If
1017 Finally:
1018 _ValidateFile = bValid
1019 _SF_.StackLevel = _SF_.StackLevel - 1
1020 Exit Function
1021 CatchMissing:
1022 bValid = False
1023 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
1024 GoTo Finally
1025 End Function ' ScriptForge.SF_Utils._ValidateFile
1027 REM -----------------------------------------------------------------------------
1028 Public Function _VarTypeExt(ByRef pvValue As Variant) As Integer
1029 ''' Return the VarType of the argument but all numeric types are aggregated into V_NUMERIC
1030 ''' Args:
1031 ''' pvValue: value to examine
1032 ''' Return:
1033 ''' The extended VarType
1035 Dim iType As Integer ' VarType of argument
1037 iType = VarType(pvValue)
1038 Select Case iType
1039 Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL
1040 _VarTypeExt = V_NUMERIC
1041 Case Else : _VarTypeExt = iType
1042 End Select
1044 End Function ' ScriptForge.SF_Utils._VarTypeExt
1046 REM -----------------------------------------------------------------------------
1047 Public Function _VarTypeObj(ByRef pvValue As Variant) As Object
1048 ''' Inspect the argument that is supposed to be an Object
1049 ''' Return the internal type of object as one of the values
1050 ''' V_NOTHING Null object
1051 ''' V_UNOOBJECT Uno object or Uno structure
1052 ''' V_SFOBJECT ScriptForge object: has ObjectType and ServiceName properties
1053 ''' V_BASICOBJECT User Basic object
1054 ''' coupled with object type as a string ("com.sun.star..." or "SF_..." or "... ScriptForge class ...")
1055 ''' When the argument is not an Object, return the usual VarType() of the argument
1057 Dim oObjDesc As _ObjectDescriptor ' Return value
1058 Dim oValue As Object ' Alias of pvValue used to avoid "Object variable not set" error
1059 Dim sObjType As String ' The type of object is first derived as a string
1060 Dim oReflection As Object ' com.sun.star.reflection.CoreReflection
1061 Dim vClass As Variant ' com.sun.star.reflection.XIdlClass
1062 Dim bUno As Boolean ' True when object recognized as UNO object
1064 Const cstBasicClass = "com.sun.star.script.NativeObjectWrapper" ' Way to recognize Basic objects
1066 On Local Error Resume Next ' Object type is established by trial and error
1068 Try:
1069 With oObjDesc
1070 .iVarType = VarType(pvValue)
1071 .sObjectType = ""
1072 .sServiceName = ""
1073 bUno = False
1074 If .iVarType = V_OBJECT Then
1075 If IsNull(pvValue) Then
1076 .iVarType = V_NOTHING
1077 Else
1078 Set oValue = pvValue
1079 ' Try UNO type with usual ImplementationName property
1080 .sObjectType = oValue.getImplementationName()
1081 If .sObjectType = "" Then
1082 ' Try UNO type with alternative CoreReflection trick
1084 vClass = oReflection.getType(oValue)
1085 If vClass.TypeClass >= com.sun.star.uno.TypeClass.STRUCT Then
1086 .sObjectType = vClass.Name
1087 bUno = True
1088 End If
1089 Else
1090 bUno = True
1091 End If
1092 ' Identify Basic objects
1093 If .sObjectType = cstBasicClass Then
1094 bUno = False
1095 ' Try if the Basic object has an ObjectType property
1096 .sObjectType = oValue.ObjectType
1097 .sServiceName = oValue.ServiceName
1098 End If
1099 ' Derive the return value from the object type
1100 Select Case True
1102 Case .sObjectType = cstBasicClass : .iVarType = V_BASICOBJECT
1103 Case bUno : .iVarType = V_UNOOBJECT
1104 Case Else : .iVarType = V_SFOBJECT
1105 End Select
1106 End If
1107 End If
1108 End With
1110 Finally:
1111 Set _VarTypeObj = oObjDesc
1112 Exit Function
1113 End Function ' ScriptForge.SF_Utils._VarTypeObj
1115 REM ================================================= END OF SCRIPTFORGE.SF_UTILS
1116 </script:module>