| blob | 23145cb991df1797fb69b9cc306304656b60903d |
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)
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(.Number2Text) Or IsNull(.Number2Text) Then
430 End If
431 Set _GetUNOService = .Number2Text
433 If IsEmpty(.OfficeLocale) Or IsNull(.OfficeLocale) Then
437 If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale")
438 .OfficeLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always
439 .OfficeLocale.Country = Right(sLocale, 2)
440 End If
441 Set _GetUNOService = .OfficeLocale
443 If IsEmpty(.PackageProvider) Or IsNull(.PackageProvider) Then
444 Set .PackageProvider = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider")
445 End If
446 Set _GetUNOService = .PackageProvider
448 If IsEmpty(.PathSettings) Or IsNull(.PathSettings) Then
450 End If
451 Set _GetUNOService = .PathSettings
453 If IsEmpty(.PathSubstitution) Or IsNull(.PathSubstitution) Then
455 End If
456 Set _GetUNOService = .PathSubstitution
458 If IsEmpty(.PrinterServer) Or IsNull(.PrinterServer) Then
460 End If
461 Set _GetUNOService = .PrinterServer
463 If IsMissing(pvArg) Then pvArg = SF_Session.SCRIPTISAPPLICATION
464 Select Case LCase(pvArg)
465 Case SF_Session.SCRIPTISEMBEDDED ' Document
466 If Not IsNull(ThisComponent) Then Set _GetUNOService = ThisComponent.getScriptProvider()
467 Case Else
468 If IsEmpty(.ScriptProvider) Or IsNull(.ScriptProvider) Then
469 Set .ScriptProvider = _
470 CreateUnoService("com.sun.star.script.provider.MasterScriptProviderFactory").createScriptProvider("")
471 End If
472 Set _GetUNOService = .ScriptProvider
473 End Select
475 If IsEmpty(.SearchOptions) Or IsNull(.SearchOptions) Then
476 Set .SearchOptions = New com.sun.star.util.SearchOptions
477 With .SearchOptions
478 .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
479 .searchFlag = 0
480 End With
481 End If
482 Set _GetUNOService = .SearchOptions
484 If IsEmpty(.SystemLocale) Or IsNull(.SystemLocale) Then
486 sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "SystemLocale")
487 .SystemLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always
488 .SystemLocale.Country = Right(sLocale, 2)
489 End If
490 Set _GetUNOService = .SystemLocale
492 If IsEmpty(.SystemShellExecute) Or IsNull(.SystemShellExecute) Then
494 End If
495 Set _GetUNOService = .SystemShellExecute
497 If IsEmpty(.TextSearch) Or IsNull(.TextSearch) Then
499 End If
500 Set _GetUNOService = .TextSearch
502 If IsEmpty(.Toolkit) Or IsNull(.Toolkit) Then
504 End If
505 Set _GetUNOService = .Toolkit
507 If IsEmpty(.URLTransformer) Or IsNull(.URLTransformer) Then
509 End If
510 Set _GetUNOService = .URLTransformer
511 Case Else
512 End Select
513 End With
515 End Function ' ScriptForge.SF_Utils._GetUNOService
517 REM -----------------------------------------------------------------------------
518 Public Sub _InitializeRoot(Optional ByVal pbForce As Boolean)
519 ''' Initialize _SF_ as SF_Root basic object
520 ''' Args:
521 ''' pbForce = True forces the reinit (default = False)
523 If IsMissing(pbForce) Then pbForce = False
524 If pbForce Then Set _SF_ = Nothing
525 If IsEmpty(_SF_) Or IsNull(_SF_) Then
526 Set _SF_ = New SF_Root
527 Set _SF_.[Me] = _SF_
528 End If
530 End Sub ' ScriptForge.SF_Utils._InitializeRoot
532 REM -----------------------------------------------------------------------------
533 Public Function _MakePropertyValue(ByVal psName As String _
534 , ByRef pvValue As Variant _
535 ) As com.sun.star.beans.PropertyValue
536 ''' Create and return a new com.sun.star.beans.PropertyValue
538 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
540 With oPropertyValue
541 .Name = psName
542 .Value = SF_Utils._CPropertyValue(pvValue)
543 End With
544 _MakePropertyValue() = oPropertyValue
546 End Function ' ScriptForge.SF_Utils._MakePropertyValue
548 REM -----------------------------------------------------------------------------
549 Public Function _Repr(ByVal pvArg As Variant, Optional ByVal plMax As Long) As String
551 ''' Args
552 ''' pvArg: may be of any type
555 Dim sArg As String ' Return value
557 Dim oObjectDesc As Object ' Object descriptor
558 Dim sLength As String ' String length as a string
559 Dim i As Long
563 Const cstByteLength = 25
566 If IsMissing(plMax) Then plMax = cstMaxLength
567 If plMax = 0 Then plMax = cstMaxLength
568 If IsArray(pvArg) Then
569 sArg = SF_Array._Repr(pvArg)
570 Else
571 Select Case VarType(pvArg)
574 Case V_OBJECT
575 Set oObjectDesc = SF_Utils._VarTypeObj(pvArg)
576 With oObjectDesc
577 Select Case .iVarType
579 Case V_OBJECT, V_BASICOBJECT
582 Case V_SFOBJECT
585 Else ' Class module must have a _Repr() method
586 Set oObject = pvArg
587 sArg = oObject._Repr()
588 End If
589 End Select
590 End With
592 Case V_STRING
593 sArg = SF_String._Repr(pvArg)
596 Case V_SINGLE, V_DOUBLE, V_CURRENCY
597 sArg = Format(pvArg)
600 Case V_BIGINT : sArg = CStr(CLng(pvArg))
601 Case V_DATE : sArg = _CDateToIso(pvArg)
602 Case Else : sArg = CStr(pvArg)
603 End Select
604 End If
605 If Len(sArg) > plMax Then
608 End If
609 _Repr = sArg
611 End Function ' ScriptForge.SF_Utils._Repr
613 REM -----------------------------------------------------------------------------
614 Private Function _ReprValues(Optional ByVal pvArgs As Variant _
615 , Optional ByVal plMax As Long _
616 ) As String
617 ''' Convert an array of values to a comma-separated list of readable strings
619 Dim sValues As String ' Return value
620 Dim sValue As String ' A single value
621 Dim vValue As Variant ' A single item in the argument
622 Dim i As Long ' Items counter
626 _ReprValues = ""
627 If IsMissing(pvArgs) Then Exit Function
628 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
629 sValues = ""
630 For i = 0 To UBound(pvArgs)
631 vValue = pvArgs(i)
632 If i < plMax Then
633 If VarType(vValue) = V_STRING Then sValue = """" & vValue & """" Else sValue = SF_Utils._Repr(vValue, cstMax)
634 If Len(sValues) = 0 Then sValues = sValue Else sValues = sValues & ", " & sValue
635 ElseIf i < UBound(pvArgs) Then
637 Exit For
638 End If
639 Next i
640 _ReprValues = sValues
642 End Function ' ScriptForge.SF_Utils._ReprValues
644 REM -----------------------------------------------------------------------------
645 Public Function _SetPropertyValue(ByVal pvPropertyValue As Variant _
646 , ByVal psName As String _
647 , ByRef pvValue As Variant _
648 ) As Variant
649 ''' Return the 1st argument (passed by reference), which is an array of property values
650 ''' If the property psName exists, update it with pvValue, otherwise create it on top of the returned array
652 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
653 Dim lIndex As Long ' Found entry
654 Dim vValue As Variant ' Alias of pvValue
655 Dim vProperties As Variant ' Alias of pvPropertyValue
656 Dim i As Long
658 lIndex = -1
659 vProperties = pvPropertyValue
660 For i = 0 To UBound(vProperties)
661 If vProperties(i).Name = psName Then
662 lIndex = i
663 Exit For
664 End If
665 Next i
667 lIndex = UBound(vProperties) + 1
668 ReDim Preserve vProperties(0 To lIndex)
669 Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue)
670 vProperties(lIndex) = oPropertyValue
671 vProperties = vProperties
672 Else ' psName exists already in array of property values
673 vProperties(lIndex).Value = SF_Utils._CPropertyValue(pvValue)
674 End If
676 _SetPropertyValue = vProperties
678 End Function ' ScriptForge.SF_Utils._SetPropertyValue
680 REM -----------------------------------------------------------------------------
681 Private Function _TypeNames(Optional ByVal pvArgs As Variant) As String
682 ''' Converts the array of VarTypes to a comma-separated list of TypeNames
684 Dim sTypes As String ' Return value
685 Dim sType As String ' A single type
686 Dim iType As Integer ' A single item of the argument
688 _TypeNames = ""
689 If IsMissing(pvArgs) Then Exit Function
690 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
691 sTypes = ""
692 For Each iType In pvArgs
693 Select Case iType
709 End Select
711 Next iType
712 _TypeNames = sTypes
714 End Function ' ScriptForge.SF_Utils._TypeNames
716 REM -----------------------------------------------------------------------------
717 Public Function _Validate(Optional ByRef pvArgument As Variant _
718 , ByVal psName As String _
719 , Optional ByVal pvTypes As Variant _
720 , Optional ByVal pvValues As Variant _
721 , Optional ByVal pvRegex As Variant _
722 , Optional ByVal pvObjectType As Variant _
723 ) As Boolean
724 ''' Validate the arguments set by user scripts
725 ''' The arguments of the function define the validation rules
726 ''' This function ignores arrays. Use _ValidateArray instead
727 ''' Args:
728 ''' pvArgument: the argument to (in)validate
729 ''' psName: the documented name of the argument (can be inserted in an error message)
730 ''' pvTypes: array of allowed VarTypes
731 ''' pvValues: array of allowed values
732 ''' pvRegex: regular expression to comply with
733 ''' pvObjectType: mandatory Basic class
734 ''' Return: True if validation OK
735 ''' Otherwise an error is raised
736 ''' Exceptions:
737 ''' ARGUMENTERROR
739 Dim iVarType As Integer ' Extended VarType of argument
740 Dim bValid As Boolean ' Returned value
741 Dim oObjectDescriptor As Object ' _ObjectDescriptor type
745 ' To avoid useless recursions, keep main function, only increase stack depth
746 _SF_.StackLevel = _SF_.StackLevel + 1
747 On Local Error GoTo Finally ' Do never interrupt
749 Try:
750 bValid = True
751 If IsMissing(pvArgument) Then GoTo CatchMissing
752 If IsMissing(pvRegex) Or IsEmpty(pvRegex) Then pvRegex = ""
753 If IsMissing(pvObjectType) Or IsEmpty(pvObjectType) Then pvObjectType = ""
754 iVarType = SF_Utils._VarTypeExt(pvArgument)
756 ' Arrays NEVER pass validation
757 If iVarType >= V_ARRAY Then
758 bValid = False
759 Else
760 ' Check existence of argument
763 If bValid And Not IsMissing(pvTypes) Then
764 If Not IsArray(pvTypes) Then bValid = ( pvTypes = iVarType ) Else bValid = SF_Array.Contains(pvTypes, iVarType)
765 End If
767 If bValid And Not IsMissing(pvValues) Then
768 If Not IsArray(pvValues) Then pvValues = Array(pvValues)
769 bValid = SF_Array.Contains(pvValues, pvArgument, CaseSensitive := False)
770 End If
771 ' Check regular expression
773 If Len(pvArgument) > 0 Then bValid = SF_String.IsRegex(pvArgument, pvRegex, CaseSensitive := False)
774 End If
775 ' Check instance types
777 'Set oArgument = pvArgument
778 Set oObjectDescriptor = SF_Utils._VarTypeObj(pvArgument)
779 bValid = ( oObjectDescriptor.iVarType = V_SFOBJECT )
780 If bValid Then bValid = ( oObjectDescriptor.sObjectType = pvObjectType )
781 End If
782 End If
784 If Not bValid Then
785 ''' Library: ScriptForge
786 ''' Service: Array
787 ''' Method: Contains
789 ''' A serious error has been detected on argument SortOrder
790 ''' Rules: SortOrder is of type String
791 ''' SortOrder must contain one of next values: "ASC", "DESC", ""
793 SF_Exception.RaiseFatal(ARGUMENTERROR _
794 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, SF_Utils._TypeNames(pvTypes) _
795 , SF_Utils._ReprValues(pvValues, cstMaxValues), pvRegex, pvObjectType _
796 )
797 End If
799 Finally:
800 _Validate = bValid
801 _SF_.StackLevel = _SF_.StackLevel - 1
802 Exit Function
803 CatchMissing:
804 bValid = False
805 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
806 GoTo Finally
807 End Function ' ScriptForge.SF_Utils._Validate
809 REM -----------------------------------------------------------------------------
810 Public Function _ValidateArray(Optional ByRef pvArray As Variant _
811 , ByVal psName As String _
812 , Optional ByVal piDimensions As Integer _
813 , Optional ByVal piType As Integer _
814 , Optional ByVal pbNotNull As Boolean _
815 ) As Boolean
816 ''' Validate the (array) arguments set by user scripts
817 ''' The arguments of the function define the validation rules
818 ''' This function ignores non-arrays. Use _Validate instead
819 ''' Args:
820 ''' pvArray: the argument to (in)validate
821 ''' psName: the documented name of the array (can be inserted in an error message)
826 ''' but homogeneously: all strings or all dates or all numeric
829 ''' If True: Empty, Null items are rejected
830 ''' Return: True if validation OK
831 ''' Otherwise an error is raised
832 ''' Exceptions:
833 ''' ARRAYERROR
835 Dim iVarType As Integer ' VarType of argument
836 Dim vItem As Variant ' Array item
837 Dim iItemType As Integer ' VarType of individual items of argument
838 Dim iDims As Integer ' Number of dimensions of the argument
839 Dim bValid As Boolean ' Returned value
840 Dim iArrayType As Integer ' Static array type
842 Dim sType As String ' Allowed item types as a string
843 Dim i As Long
846 ' To avoid useless recursions, keep main function, only increase stack depth
848 _SF_.StackLevel = _SF_.StackLevel + 1
849 On Local Error GoTo Finally ' Do never interrupt
851 Try:
852 bValid = True
853 If IsMissing(pvArray) Then GoTo CatchMissing
854 If IsMissing(piDimensions) Then piDimensions = 0
855 If IsMissing(piType) Then piType = -1
856 If IsMissing(pbNotNull) Then pbNotNull = False
857 iVarType = VarType(pvArray)
859 ' Scalars NEVER pass validation
860 If iVarType < V_ARRAY Then
861 bValid = False
862 Else
863 ' Check dimensions
864 iDims = SF_Array.CountDims(pvArray)
867 bValid = ( iDims = piDimensions Or (iDims = 0 And piDimensions = 1) ) ' Allow empty vectors
868 End If
869 ' Check VarType and Empty/Null status of the array items
871 iArrayType = SF_Array._StaticType(pvArray)
873 ' If static array of the right VarType ..., OK
874 Else
875 ' Go through array and check individual items
876 iFirstItemType = -1
879 iItemType = SF_Utils._VarTypeExt(vItem)
881 ' Initialization at first non-null item
883 iFirstItemType = iItemType
884 If piType > 0 Then bValid = ( iFirstItemType = piType ) Else bValid = SF_Array.Contains(Array(V_STRING, V_DATE, V_NUMERIC), iFirstItemType)
885 Else
886 bValid = (iItemType = iFirstItemType)
887 End If
888 Else
889 bValid = Not pbNotNull
890 End If
891 If Not bValid Then Exit For
892 Next i
893 End If
894 End If
895 End If
897 If Not bValid Then
898 ''' Library: ScriptForge
899 ''' Service: Array
900 ''' Method: Contains
901 ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""|"ASC"|"DESC"]
902 ''' An error was detected on argument Array_1D
903 ''' Rules: Array_1D is of type Array
905 ''' Array_1D must have all elements of the same type: either String, Date or Numeric
907 sType = ""
908 If piType = 0 Then
911 sType = SF_Utils._TypeNames(piType)
912 End If
913 SF_Exception.RaiseFatal(ARRAYERROR _
914 , SF_Utils._Repr(pvArray, cstMaxLength), psName, piDimensions, sType, pbNotNull)
915 End If
917 Finally:
918 _ValidateArray = bValid
919 _SF_.StackLevel = _SF_.StackLevel - 1
920 Exit Function
921 CatchMissing:
922 bValid = False
923 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
924 GoTo Finally
925 End Function ' ScriptForge.SF_Utils._ValidateArray
927 REM -----------------------------------------------------------------------------
928 Public Function _ValidateFile(Optional ByRef pvArgument As Variant _
929 , ByVal psName As String _
930 , Optional ByVal pbWildCards As Boolean _
931 , Optional ByVal pbSpace As Boolean _
932 )
933 ''' Validate the argument as a valid FileName
934 ''' Args:
935 ''' pvArgument: the argument to (in)validate
936 ''' pbWildCards: if True, wildcard characters are accepted in the last component of the 1st argument
937 ''' pbSpace: if True, the argument may be an empty string. Default = False
938 ''' Return: True if validation OK
939 ''' Otherwise an error is raised
940 ''' Exceptions:
941 ''' ARGUMENTERROR
943 Dim iVarType As Integer ' VarType of argument
944 Dim sFile As String ' Alias for argument
945 Dim bValid As Boolean ' Returned value
946 Dim sFileNaming As String ' Alias of SF_FileSystem.FileNaming
947 Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement
950 ' To avoid useless recursions, keep main function, only increase stack depth
952 _SF_.StackLevel = _SF_.StackLevel + 1
953 On Local Error GoTo Finally ' Do never interrupt
955 Try:
956 bValid = True
957 If IsMissing(pvArgument) Then GoTo CatchMissing
958 If IsMissing(pbWildCards) Then pbWildCards = False
959 If IsMissing(pbSpace) Then pbSpace = False
960 iVarType = VarType(pvArgument)
962 ' Arrays NEVER pass validation
963 If iVarType >= V_ARRAY Then
964 bValid = False
965 Else
966 ' Argument must be a string containing a valid file name
967 bValid = ( iVarType = V_STRING )
968 If bValid Then
971 ' Wildcards are replaced by arbitrary alpha characters
972 If pbWildCards Then
973 sFile = Replace(Replace(pvArgument, "?", "Z"), "*", "A")
974 Else
975 sFile = pvArgument
977 End If
978 ' Check file format without wildcards
979 If bValid Then
980 With SF_FileSystem
981 sFileNaming = .FileNaming
982 Select Case sFileNaming
986 End Select
987 End With
988 End If
989 ' Check that wildcards are only present in last component
990 If bValid And pbWildCards Then
991 sFile = SF_FileSystem.GetParentFolderName(pvArgument)
992 bValid = ( InStr(sFile, "*") + InStr(sFile, "?") + InStr(sFile,"%3F") = 0 ) ' ConvertToUrl replaces ? by %3F
993 End If
994 End If
995 End If
996 End If
998 If Not bValid Then
999 ''' Library: ScriptForge
1000 ''' Service: FileSystem
1001 ''' Method: CopyFile
1002 ''' Arguments: Source, Destination
1003 ''' A serious error has been detected on argument Source
1004 ''' Rules: Source is of type String
1005 ''' Source must be a valid file name expressed in operating system notation
1006 ''' Source may contain one or more wildcard characters in its last component
1007 ''' Actual value: /home/jean-*/SomeFile.odt
1008 SF_Exception.RaiseFatal(FILEERROR _
1009 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, pbWildCards)
1010 End If
1012 Finally:
1013 _ValidateFile = bValid
1014 _SF_.StackLevel = _SF_.StackLevel - 1
1015 Exit Function
1016 CatchMissing:
1017 bValid = False
1018 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
1019 GoTo Finally
1020 End Function ' ScriptForge.SF_Utils._ValidateFile
1022 REM -----------------------------------------------------------------------------
1023 Public Function _VarTypeExt(ByRef pvValue As Variant) As Integer
1024 ''' Return the VarType of the argument but all numeric types are aggregated into V_NUMERIC
1025 ''' Args:
1026 ''' pvValue: value to examine
1027 ''' Return:
1028 ''' The extended VarType
1030 Dim iType As Integer ' VarType of argument
1032 iType = VarType(pvValue)
1033 Select Case iType
1034 Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL
1035 _VarTypeExt = V_NUMERIC
1036 Case Else : _VarTypeExt = iType
1037 End Select
1039 End Function ' ScriptForge.SF_Utils._VarTypeExt
1041 REM -----------------------------------------------------------------------------
1042 Public Function _VarTypeObj(ByRef pvValue As Variant) As Object
1043 ''' Inspect the argument that is supposed to be an Object
1044 ''' Return the internal type of object as one of the values
1045 ''' V_NOTHING Null object
1046 ''' V_UNOOBJECT Uno object or Uno structure
1047 ''' V_SFOBJECT ScriptForge object: has ObjectType and ServiceName properties
1048 ''' V_BASICOBJECT User Basic object
1049 ''' coupled with object type as a string ("com.sun.star..." or "SF_..." or "... ScriptForge class ...")
1050 ''' When the argument is not an Object, return the usual VarType() of the argument
1052 Dim oObjDesc As _ObjectDescriptor ' Return value
1053 Dim oValue As Object ' Alias of pvValue used to avoid "Object variable not set" error
1054 Dim sObjType As String ' The type of object is first derived as a string
1055 Dim oReflection As Object ' com.sun.star.reflection.CoreReflection
1056 Dim vClass As Variant ' com.sun.star.reflection.XIdlClass
1057 Dim bUno As Boolean ' True when object recognized as UNO object
1059 Const cstBasicClass = "com.sun.star.script.NativeObjectWrapper" ' Way to recognize Basic objects
1061 On Local Error Resume Next ' Object type is established by trial and error
1063 Try:
1064 With oObjDesc
1065 .iVarType = VarType(pvValue)
1066 .sObjectType = ""
1067 .sServiceName = ""
1068 bUno = False
1069 If .iVarType = V_OBJECT Then
1070 If IsNull(pvValue) Then
1071 .iVarType = V_NOTHING
1072 Else
1073 Set oValue = pvValue
1074 ' Try UNO type with usual ImplementationName property
1075 .sObjectType = oValue.getImplementationName()
1076 If .sObjectType = "" Then
1077 ' Try UNO type with alternative CoreReflection trick
1079 vClass = oReflection.getType(oValue)
1080 If vClass.TypeClass >= com.sun.star.uno.TypeClass.STRUCT Then
1081 .sObjectType = vClass.Name
1082 bUno = True
1083 End If
1084 Else
1085 bUno = True
1086 End If
1087 ' Identify Basic objects
1088 If .sObjectType = cstBasicClass Then
1089 bUno = False
1090 ' Try if the Basic object has an ObjectType property
1091 .sObjectType = oValue.ObjectType
1092 .sServiceName = oValue.ServiceName
1093 End If
1094 ' Derive the return value from the object type
1095 Select Case True
1097 Case .sObjectType = cstBasicClass : .iVarType = V_BASICOBJECT
1098 Case bUno : .iVarType = V_UNOOBJECT
1099 Case Else : .iVarType = V_SFOBJECT
1100 End Select
1101 End If
1102 End If
1103 End With
1105 Finally:
1106 Set _VarTypeObj = oObjDesc
1107 Exit Function
1108 End Function ' ScriptForge.SF_Utils._VarTypeObj
1110 REM ================================================= END OF SCRIPTFORGE.SF_UTILS
1111 </script:module>