| blob | 323978db2211b11023f9b867555cdd89103f5d5e |
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(.TransientDocument) Or IsNull(.TransientDocument) Then
513 Set .TransientDocument = CreateUnoService("com.sun.star.frame.TransientDocumentsDocumentContentFactory")
514 End If
515 Set _GetUNOService = .TransientDocument
517 If IsEmpty(.URLTransformer) Or IsNull(.URLTransformer) Then
519 End If
520 Set _GetUNOService = .URLTransformer
521 Case Else
522 End Select
523 End With
525 End Function ' ScriptForge.SF_Utils._GetUNOService
527 REM -----------------------------------------------------------------------------
528 Public Sub _InitializeRoot(Optional ByVal pbForce As Boolean)
529 ''' Initialize _SF_ as SF_Root basic object
530 ''' Args:
531 ''' pbForce = True forces the reinit (default = False)
533 If IsMissing(pbForce) Then pbForce = False
534 If pbForce Then Set _SF_ = Nothing
535 If IsEmpty(_SF_) Or IsNull(_SF_) Then
536 Set _SF_ = New SF_Root
537 Set _SF_.[Me] = _SF_
538 End If
540 End Sub ' ScriptForge.SF_Utils._InitializeRoot
542 REM -----------------------------------------------------------------------------
543 Public Function _MakePropertyValue(ByVal psName As String _
544 , ByRef pvValue As Variant _
545 ) As com.sun.star.beans.PropertyValue
546 ''' Create and return a new com.sun.star.beans.PropertyValue
548 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
550 With oPropertyValue
551 .Name = psName
552 .Value = SF_Utils._CPropertyValue(pvValue)
553 End With
554 _MakePropertyValue() = oPropertyValue
556 End Function ' ScriptForge.SF_Utils._MakePropertyValue
558 REM -----------------------------------------------------------------------------
559 Public Function _Repr(ByVal pvArg As Variant, Optional ByVal plMax As Long) As String
561 ''' Args
562 ''' pvArg: may be of any type
565 Dim sArg As String ' Return value
567 Dim oObjectDesc As Object ' Object descriptor
568 Dim sLength As String ' String length as a string
569 Dim i As Long
573 Const cstByteLength = 25
576 If IsMissing(plMax) Then plMax = cstMaxLength
577 If plMax = 0 Then plMax = cstMaxLength
578 If IsArray(pvArg) Then
579 sArg = SF_Array._Repr(pvArg)
580 Else
581 Select Case VarType(pvArg)
584 Case V_OBJECT
585 Set oObjectDesc = SF_Utils._VarTypeObj(pvArg)
586 With oObjectDesc
587 Select Case .iVarType
589 Case V_OBJECT, V_BASICOBJECT
592 Case V_SFOBJECT
595 Else ' Class module must have a _Repr() method
596 Set oObject = pvArg
597 sArg = oObject._Repr()
598 End If
599 End Select
600 End With
602 Case V_STRING
603 sArg = SF_String._Repr(pvArg)
606 Case V_SINGLE, V_DOUBLE, V_CURRENCY
607 sArg = Format(pvArg)
610 Case V_BIGINT : sArg = CStr(CLng(pvArg))
611 Case V_DATE : sArg = _CDateToIso(pvArg)
612 Case Else : sArg = CStr(pvArg)
613 End Select
614 End If
615 If Len(sArg) > plMax Then
618 End If
619 _Repr = sArg
621 End Function ' ScriptForge.SF_Utils._Repr
623 REM -----------------------------------------------------------------------------
624 Private Function _ReprValues(Optional ByVal pvArgs As Variant _
625 , Optional ByVal plMax As Long _
626 ) As String
627 ''' Convert an array of values to a comma-separated list of readable strings
629 Dim sValues As String ' Return value
630 Dim sValue As String ' A single value
631 Dim vValue As Variant ' A single item in the argument
632 Dim i As Long ' Items counter
636 _ReprValues = ""
637 If IsMissing(pvArgs) Then Exit Function
638 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
639 sValues = ""
640 For i = 0 To UBound(pvArgs)
641 vValue = pvArgs(i)
642 If i < plMax Then
643 If VarType(vValue) = V_STRING Then sValue = """" & vValue & """" Else sValue = SF_Utils._Repr(vValue, cstMax)
644 If Len(sValues) = 0 Then sValues = sValue Else sValues = sValues & ", " & sValue
645 ElseIf i < UBound(pvArgs) Then
647 Exit For
648 End If
649 Next i
650 _ReprValues = sValues
652 End Function ' ScriptForge.SF_Utils._ReprValues
654 REM -----------------------------------------------------------------------------
655 Public Function _SetPropertyValue(ByVal pvPropertyValue As Variant _
656 , ByVal psName As String _
657 , ByRef pvValue As Variant _
658 ) As Variant
659 ''' Return the 1st argument (passed by reference), which is an array of property values
660 ''' If the property psName exists, update it with pvValue, otherwise create it on top of the returned array
662 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
663 Dim lIndex As Long ' Found entry
664 Dim vValue As Variant ' Alias of pvValue
665 Dim vProperties As Variant ' Alias of pvPropertyValue
666 Dim i As Long
668 lIndex = -1
669 vProperties = pvPropertyValue
670 For i = 0 To UBound(vProperties)
671 If vProperties(i).Name = psName Then
672 lIndex = i
673 Exit For
674 End If
675 Next i
677 lIndex = UBound(vProperties) + 1
678 ReDim Preserve vProperties(0 To lIndex)
679 Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue)
680 vProperties(lIndex) = oPropertyValue
681 vProperties = vProperties
682 Else ' psName exists already in array of property values
683 vProperties(lIndex).Value = SF_Utils._CPropertyValue(pvValue)
684 End If
686 _SetPropertyValue = vProperties
688 End Function ' ScriptForge.SF_Utils._SetPropertyValue
690 REM -----------------------------------------------------------------------------
691 Private Function _TypeNames(Optional ByVal pvArgs As Variant) As String
692 ''' Converts the array of VarTypes to a comma-separated list of TypeNames
694 Dim sTypes As String ' Return value
695 Dim sType As String ' A single type
696 Dim iType As Integer ' A single item of the argument
698 _TypeNames = ""
699 If IsMissing(pvArgs) Then Exit Function
700 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
701 sTypes = ""
702 For Each iType In pvArgs
703 Select Case iType
719 End Select
721 Next iType
722 _TypeNames = sTypes
724 End Function ' ScriptForge.SF_Utils._TypeNames
726 REM -----------------------------------------------------------------------------
727 Public Function _Validate(Optional ByRef pvArgument As Variant _
728 , ByVal psName As String _
729 , Optional ByVal pvTypes As Variant _
730 , Optional ByVal pvValues As Variant _
731 , Optional ByVal pvCaseSensitive As Variant _
732 , Optional ByVal pvObjectType As Variant _
733 ) As Boolean
734 ''' Validate the arguments set by user scripts
735 ''' The arguments of the function define the validation rules
736 ''' This function ignores arrays. Use _ValidateArray instead
737 ''' Args:
738 ''' pvArgument: the argument to (in)validate
739 ''' psName: the documented name of the argument (can be inserted in an error message)
740 ''' pvTypes: array of allowed VarTypes
741 ''' pvValues: array of allowed values
742 ''' pvCaseSensitive: when True the comparison between strings is done case-sensitively
743 ''' pvObjectType: mandatory Basic class
744 ''' Return: True if validation OK
745 ''' Otherwise an error is raised
746 ''' Exceptions:
747 ''' ARGUMENTERROR
749 Dim iVarType As Integer ' Extended VarType of argument
750 Dim bValid As Boolean ' Returned value
751 Dim oObjectDescriptor As Object ' _ObjectDescriptor type
755 ' To avoid useless recursions, keep main function, only increase stack depth
756 _SF_.StackLevel = _SF_.StackLevel + 1
757 On Local Error GoTo Finally ' Do never interrupt
759 Try:
760 bValid = True
761 If IsMissing(pvArgument) Then GoTo CatchMissing
762 If IsMissing(pvCaseSensitive) Or IsEmpty(pvCaseSensitive) Then pvCaseSensitive = False
763 If IsMissing(pvObjectType) Or IsEmpty(pvObjectType) Then pvObjectType = ""
764 iVarType = SF_Utils._VarTypeExt(pvArgument)
766 ' Arrays NEVER pass validation
767 If iVarType >= V_ARRAY Then
768 bValid = False
769 Else
770 ' Check existence of argument
773 If bValid And Not IsMissing(pvTypes) Then
774 If Not IsArray(pvTypes) Then bValid = ( pvTypes = iVarType ) Else bValid = SF_Array.Contains(pvTypes, iVarType)
775 End If
777 If bValid And Not IsMissing(pvValues) Then
778 If Not IsArray(pvValues) Then pvValues = Array(pvValues)
779 bValid = SF_Array.Contains(pvValues, pvArgument, CaseSensitive := pvCaseSensitive)
780 End If
781 ' Check instance types
783 'Set oArgument = pvArgument
784 Set oObjectDescriptor = SF_Utils._VarTypeObj(pvArgument)
785 bValid = ( oObjectDescriptor.iVarType = V_SFOBJECT )
786 If bValid Then bValid = ( oObjectDescriptor.sObjectType = pvObjectType )
787 End If
788 End If
790 If Not bValid Then
791 ''' Library: ScriptForge
792 ''' Service: Array
793 ''' Method: Contains
795 ''' A serious error has been detected on argument SortOrder
796 ''' Rules: SortOrder is of type String
797 ''' SortOrder must contain one of next values: "ASC", "DESC", ""
799 SF_Exception.RaiseFatal(ARGUMENTERROR _
800 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, SF_Utils._TypeNames(pvTypes) _
801 , SF_Utils._ReprValues(pvValues, cstMaxValues), pvCaseSensitive, pvObjectType _
802 )
803 End If
805 Finally:
806 _Validate = bValid
807 _SF_.StackLevel = _SF_.StackLevel - 1
808 Exit Function
809 CatchMissing:
810 bValid = False
811 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
812 GoTo Finally
813 End Function ' ScriptForge.SF_Utils._Validate
815 REM -----------------------------------------------------------------------------
816 Public Function _ValidateArray(Optional ByRef pvArray As Variant _
817 , ByVal psName As String _
818 , Optional ByVal piDimensions As Integer _
819 , Optional ByVal piType As Integer _
820 , Optional ByVal pbNotNull As Boolean _
821 ) As Boolean
822 ''' Validate the (array) arguments set by user scripts
823 ''' The arguments of the function define the validation rules
824 ''' This function ignores non-arrays. Use _Validate instead
825 ''' Args:
826 ''' pvArray: the argument to (in)validate
827 ''' psName: the documented name of the array (can be inserted in an error message)
832 ''' but homogeneously: all strings or all dates or all numeric
835 ''' If True: Empty, Null items are rejected
836 ''' Return: True if validation OK
837 ''' Otherwise an error is raised
838 ''' Exceptions:
839 ''' ARRAYERROR
841 Dim iVarType As Integer ' VarType of argument
842 Dim vItem As Variant ' Array item
843 Dim iItemType As Integer ' VarType of individual items of argument
844 Dim iDims As Integer ' Number of dimensions of the argument
845 Dim bValid As Boolean ' Returned value
846 Dim iArrayType As Integer ' Static array type
848 Dim sType As String ' Allowed item types as a string
849 Dim i As Long
852 ' To avoid useless recursions, keep main function, only increase stack depth
854 _SF_.StackLevel = _SF_.StackLevel + 1
855 On Local Error GoTo Finally ' Do never interrupt
857 Try:
858 bValid = True
859 If IsMissing(pvArray) Then GoTo CatchMissing
860 If IsMissing(piDimensions) Then piDimensions = 0
861 If IsMissing(piType) Then piType = -1
862 If IsMissing(pbNotNull) Then pbNotNull = False
863 iVarType = VarType(pvArray)
865 ' Scalars NEVER pass validation
866 If iVarType < V_ARRAY Then
867 bValid = False
868 Else
869 ' Check dimensions
870 iDims = SF_Array.CountDims(pvArray)
873 bValid = ( iDims = piDimensions Or (iDims = 0 And piDimensions = 1) ) ' Allow empty vectors
874 End If
875 ' Check VarType and Empty/Null status of the array items
877 iArrayType = SF_Array._StaticType(pvArray)
879 ' If static array of the right VarType ..., OK
880 Else
881 ' Go through array and check individual items
882 iFirstItemType = -1
885 iItemType = SF_Utils._VarTypeExt(vItem)
887 ' Initialization at first non-null item
889 iFirstItemType = iItemType
890 If piType > 0 Then bValid = ( iFirstItemType = piType ) Else bValid = SF_Array.Contains(Array(V_STRING, V_DATE, V_NUMERIC), iFirstItemType)
891 Else
892 bValid = (iItemType = iFirstItemType)
893 End If
894 Else
895 bValid = Not pbNotNull
896 End If
897 If Not bValid Then Exit For
898 Next i
899 End If
900 End If
901 End If
903 If Not bValid Then
904 ''' Library: ScriptForge
905 ''' Service: Array
906 ''' Method: Contains
907 ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""|"ASC"|"DESC"]
908 ''' An error was detected on argument Array_1D
909 ''' Rules: Array_1D is of type Array
911 ''' Array_1D must have all elements of the same type: either String, Date or Numeric
913 sType = ""
914 If piType = 0 Then
917 sType = SF_Utils._TypeNames(piType)
918 End If
919 SF_Exception.RaiseFatal(ARRAYERROR _
920 , SF_Utils._Repr(pvArray, cstMaxLength), psName, piDimensions, sType, pbNotNull)
921 End If
923 Finally:
924 _ValidateArray = bValid
925 _SF_.StackLevel = _SF_.StackLevel - 1
926 Exit Function
927 CatchMissing:
928 bValid = False
929 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
930 GoTo Finally
931 End Function ' ScriptForge.SF_Utils._ValidateArray
933 REM -----------------------------------------------------------------------------
934 Public Function _ValidateFile(Optional ByRef pvArgument As Variant _
935 , ByVal psName As String _
936 , Optional ByVal pbWildCards As Boolean _
937 , Optional ByVal pbSpace As Boolean _
938 )
939 ''' Validate the argument as a valid FileName
940 ''' Args:
941 ''' pvArgument: the argument to (in)validate
942 ''' pbWildCards: if True, wildcard characters are accepted in the last component of the 1st argument
943 ''' pbSpace: if True, the argument may be an empty string. Default = False
944 ''' Return: True if validation OK
945 ''' Otherwise an error is raised
946 ''' Exceptions:
947 ''' ARGUMENTERROR
949 Dim iVarType As Integer ' VarType of argument
950 Dim sFile As String ' Alias for argument
951 Dim bValid As Boolean ' Returned value
952 Dim sFileNaming As String ' Alias of SF_FileSystem.FileNaming
953 Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement
957 ' To avoid useless recursions, keep main function, only increase stack depth
959 _SF_.StackLevel = _SF_.StackLevel + 1
960 On Local Error GoTo Finally ' Do never interrupt
962 Try:
963 bValid = True
964 If IsMissing(pvArgument) Then GoTo CatchMissing
965 If IsMissing(pbWildCards) Then pbWildCards = False
966 If IsMissing(pbSpace) Then pbSpace = False
967 iVarType = VarType(pvArgument)
969 ' Arrays NEVER pass validation
970 If iVarType >= V_ARRAY Then
971 bValid = False
972 Else
973 ' Argument must be a string containing a valid file name
974 bValid = ( iVarType = V_STRING )
975 If bValid Then
978 ' Wildcards are replaced by arbitrary alpha characters
979 If pbWildCards Then
980 sFile = Replace(Replace(pvArgument, "?", "Z"), "*", "A")
981 Else
982 sFile = pvArgument
984 End If
985 ' Check file format without wildcards
986 If bValid Then
987 With SF_FileSystem
988 sFileNaming = .FileNaming
990 Select Case sFileNaming
994 End Select
995 End With
996 End If
997 ' Check that wildcards are only present in last component
998 If bValid And pbWildCards Then
999 sFile = SF_FileSystem.GetParentFolderName(pvArgument)
1000 bValid = ( InStr(sFile, "*") + InStr(sFile, "?") + InStr(sFile,"%3F") = 0 ) ' ConvertToUrl replaces ? by %3F
1001 End If
1002 End If
1003 End If
1004 End If
1006 If Not bValid Then
1007 ''' Library: ScriptForge
1008 ''' Service: FileSystem
1009 ''' Method: CopyFile
1010 ''' Arguments: Source, Destination
1011 ''' A serious error has been detected on argument Source
1012 ''' Rules: Source is of type String
1013 ''' Source must be a valid file name expressed in operating system notation
1014 ''' Source may contain one or more wildcard characters in its last component
1015 ''' Actual value: /home/jean-*/SomeFile.odt
1016 SF_Exception.RaiseFatal(FILEERROR _
1017 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, pbWildCards)
1018 End If
1020 Finally:
1021 _ValidateFile = bValid
1022 _SF_.StackLevel = _SF_.StackLevel - 1
1023 Exit Function
1024 CatchMissing:
1025 bValid = False
1026 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
1027 GoTo Finally
1028 End Function ' ScriptForge.SF_Utils._ValidateFile
1030 REM -----------------------------------------------------------------------------
1031 Public Function _VarTypeExt(ByRef pvValue As Variant) As Integer
1032 ''' Return the VarType of the argument but all numeric types are aggregated into V_NUMERIC
1033 ''' Args:
1034 ''' pvValue: value to examine
1035 ''' Return:
1036 ''' The extended VarType
1038 Dim iType As Integer ' VarType of argument
1040 iType = VarType(pvValue)
1041 Select Case iType
1042 Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL
1043 _VarTypeExt = V_NUMERIC
1044 Case Else : _VarTypeExt = iType
1045 End Select
1047 End Function ' ScriptForge.SF_Utils._VarTypeExt
1049 REM -----------------------------------------------------------------------------
1050 Public Function _VarTypeObj(ByRef pvValue As Variant) As Object
1051 ''' Inspect the argument that is supposed to be an Object
1052 ''' Return the internal type of object as one of the values
1053 ''' V_NOTHING Null object
1054 ''' V_UNOOBJECT Uno object or Uno structure
1055 ''' V_SFOBJECT ScriptForge object: has ObjectType and ServiceName properties
1056 ''' V_BASICOBJECT User Basic object
1057 ''' coupled with object type as a string ("com.sun.star..." or "SF_..." or "... ScriptForge class ...")
1058 ''' When the argument is not an Object, return the usual VarType() of the argument
1060 Dim oObjDesc As _ObjectDescriptor ' Return value
1061 Dim oValue As Object ' Alias of pvValue used to avoid "Object variable not set" error
1062 Dim sObjType As String ' The type of object is first derived as a string
1063 Dim oReflection As Object ' com.sun.star.reflection.CoreReflection
1064 Dim vClass As Variant ' com.sun.star.reflection.XIdlClass
1065 Dim bUno As Boolean ' True when object recognized as UNO object
1067 Const cstBasicClass = "com.sun.star.script.NativeObjectWrapper" ' Way to recognize Basic objects
1069 On Local Error Resume Next ' Object type is established by trial and error
1071 Try:
1072 With oObjDesc
1073 .iVarType = VarType(pvValue)
1074 .sObjectType = ""
1075 .sServiceName = ""
1076 bUno = False
1077 If .iVarType = V_OBJECT Then
1078 If IsNull(pvValue) Then
1079 .iVarType = V_NOTHING
1080 Else
1081 Set oValue = pvValue
1082 ' Try UNO type with usual ImplementationName property
1083 .sObjectType = oValue.getImplementationName()
1084 If .sObjectType = "" Then
1085 ' Try UNO type with alternative CoreReflection trick
1087 vClass = oReflection.getType(oValue)
1088 If vClass.TypeClass >= com.sun.star.uno.TypeClass.STRUCT Then
1089 .sObjectType = vClass.Name
1090 bUno = True
1091 End If
1092 Else
1093 bUno = True
1094 End If
1095 ' Identify Basic objects
1096 If .sObjectType = cstBasicClass Then
1097 bUno = False
1098 ' Try if the Basic object has an ObjectType property
1099 .sObjectType = oValue.ObjectType
1100 .sServiceName = oValue.ServiceName
1101 End If
1102 ' Derive the return value from the object type
1103 Select Case True
1105 Case .sObjectType = cstBasicClass : .iVarType = V_BASICOBJECT
1106 Case bUno : .iVarType = V_UNOOBJECT
1107 Case Else : .iVarType = V_SFOBJECT
1108 End Select
1109 End If
1110 End If
1111 End With
1113 Finally:
1114 Set _VarTypeObj = oObjDesc
1115 Exit Function
1116 End Function ' ScriptForge.SF_Utils._VarTypeObj
1118 REM ================================================= END OF SCRIPTFORGE.SF_UTILS
1119 </script:module>