From ed5640d8b587fbcfed7dd7967f3de04b37a76f26 Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Sun, 7 Apr 2024 11:06:44 +0200 Subject: Adding upstream version 4:7.4.7. Signed-off-by: Daniel Baumann --- wizards/source/access2base/Application.xba | 1869 ++++++++ wizards/source/access2base/Collect.xba | 399 ++ wizards/source/access2base/CommandBar.xba | 396 ++ wizards/source/access2base/CommandBarControl.xba | 339 ++ wizards/source/access2base/Control.xba | 2501 +++++++++++ wizards/source/access2base/DataDef.xba | 598 +++ wizards/source/access2base/Database.xba | 1889 ++++++++ wizards/source/access2base/Dialog.xba | 818 ++++ wizards/source/access2base/DoCmd.xba | 2662 ++++++++++++ wizards/source/access2base/Event.xba | 493 +++ wizards/source/access2base/Field.xba | 923 ++++ wizards/source/access2base/Form.xba | 1129 +++++ wizards/source/access2base/L10N.xba | 540 +++ wizards/source/access2base/Methods.xba | 300 ++ wizards/source/access2base/Module.xba | 722 ++++ wizards/source/access2base/OptionGroup.xba | 315 ++ wizards/source/access2base/PropertiesGet.xba | 1120 +++++ wizards/source/access2base/PropertiesSet.xba | 577 +++ wizards/source/access2base/Property.xba | 152 + wizards/source/access2base/Python.xba | 613 +++ wizards/source/access2base/Recordset.xba | 1274 ++++++ wizards/source/access2base/Root_.xba | 311 ++ wizards/source/access2base/SubForm.xba | 757 ++++ wizards/source/access2base/TempVar.xba | 195 + wizards/source/access2base/Test.xba | 14 + wizards/source/access2base/Trace.xba | 438 ++ wizards/source/access2base/UtilProperty.xba | 331 ++ wizards/source/access2base/Utils.xba | 1308 ++++++ wizards/source/access2base/_License.xba | 25 + wizards/source/access2base/acConstants.xba | 395 ++ wizards/source/access2base/access2base.py | 1473 +++++++ wizards/source/access2base/dialog.xlb | 6 + wizards/source/access2base/dlgFormat.xdl | 19 + wizards/source/access2base/dlgTrace.xdl | 33 + wizards/source/access2base/script.xlb | 34 + wizards/source/config/dialog.xlc | 5 + wizards/source/config/script.xlc | 5 + wizards/source/configshare/dialog.xlc | 19 + wizards/source/configshare/script.xlc | 19 + wizards/source/depot/CommonLang.xba | 368 ++ wizards/source/depot/Currency.xba | 195 + wizards/source/depot/Depot.xba | 517 +++ wizards/source/depot/Dialog2.xdl | 53 + wizards/source/depot/Dialog3.xdl | 62 + wizards/source/depot/Dialog4.xdl | 34 + wizards/source/depot/Internet.xba | 356 ++ wizards/source/depot/Lang_de.xba | 175 + wizards/source/depot/Lang_en.xba | 175 + wizards/source/depot/Lang_es.xba | 175 + wizards/source/depot/Lang_fr.xba | 175 + wizards/source/depot/Lang_it.xba | 175 + wizards/source/depot/Lang_ja.xba | 175 + wizards/source/depot/Lang_ko.xba | 175 + wizards/source/depot/Lang_sv.xba | 174 + wizards/source/depot/Lang_tw.xba | 175 + wizards/source/depot/Lang_zh.xba | 175 + wizards/source/depot/dialog.xlb | 7 + wizards/source/depot/script.xlb | 19 + wizards/source/depot/tools.xba | 217 + wizards/source/euro/AutoPilotRun.xba | 415 ++ wizards/source/euro/Common.xba | 289 ++ wizards/source/euro/ConvertRun.xba | 334 ++ wizards/source/euro/DlgConvert.xdl | 94 + wizards/source/euro/DlgPassword.xdl | 32 + wizards/source/euro/Hard.xba | 246 ++ wizards/source/euro/Init.xba | 667 +++ wizards/source/euro/Protect.xba | 192 + wizards/source/euro/Soft.xba | 256 ++ wizards/source/euro/Writer.xba | 89 + wizards/source/euro/dialog.xlb | 6 + wizards/source/euro/script.xlb | 12 + wizards/source/formwizard/DBMeta.xba | 347 ++ wizards/source/formwizard/DlgFormDB.xdl | 111 + wizards/source/formwizard/FormWizard.xba | 440 ++ wizards/source/formwizard/Language.xba | 297 ++ wizards/source/formwizard/Layouter.xba | 397 ++ wizards/source/formwizard/develop.xba | 550 +++ wizards/source/formwizard/dialog.xlb | 5 + wizards/source/formwizard/script.xlb | 10 + wizards/source/formwizard/tools.xba | 363 ++ wizards/source/gimmicks/AutoText.xba | 114 + wizards/source/gimmicks/ChangeAllChars.xba | 92 + wizards/source/gimmicks/GetTexts.xba | 536 +++ wizards/source/gimmicks/ReadDir.xba | 322 ++ wizards/source/gimmicks/ReadFolderDlg.xdl | 39 + wizards/source/gimmicks/UserfieldDlg.xdl | 66 + wizards/source/gimmicks/Userfields.xba | 236 + wizards/source/gimmicks/dialog.xlb | 6 + wizards/source/gimmicks/readdirs.dlg | Bin 0 -> 3180 bytes wizards/source/gimmicks/script.xlb | 9 + wizards/source/imagelists/imagelists.ilst | 7 + wizards/source/importwizard/API.xba | 216 + wizards/source/importwizard/DialogModul.xba | 484 +++ wizards/source/importwizard/FilesModul.xba | 783 ++++ wizards/source/importwizard/ImportDialog.xdl | 97 + wizards/source/importwizard/Language.xba | 150 + wizards/source/importwizard/Main.xba | 291 ++ wizards/source/importwizard/dialog.xlb | 5 + wizards/source/importwizard/script.xlb | 9 + .../source/resources/resources_en_US.properties | 579 +++ wizards/source/scriptforge/SF_Array.xba | 2608 ++++++++++++ wizards/source/scriptforge/SF_Dictionary.xba | 959 +++++ wizards/source/scriptforge/SF_Exception.xba | 1381 ++++++ wizards/source/scriptforge/SF_FileSystem.xba | 2128 +++++++++ wizards/source/scriptforge/SF_L10N.xba | 825 ++++ wizards/source/scriptforge/SF_Platform.xba | 451 ++ wizards/source/scriptforge/SF_PythonHelper.xba | 967 +++++ wizards/source/scriptforge/SF_Region.xba | 861 ++++ wizards/source/scriptforge/SF_Root.xba | 1070 +++++ wizards/source/scriptforge/SF_Services.xba | 639 +++ wizards/source/scriptforge/SF_Session.xba | 1076 +++++ wizards/source/scriptforge/SF_String.xba | 2734 ++++++++++++ wizards/source/scriptforge/SF_TextStream.xba | 702 +++ wizards/source/scriptforge/SF_Timer.xba | 466 ++ wizards/source/scriptforge/SF_UI.xba | 1350 ++++++ wizards/source/scriptforge/SF_Utils.xba | 1113 +++++ wizards/source/scriptforge/_CodingConventions.xba | 100 + wizards/source/scriptforge/_ModuleModel.xba | 221 + wizards/source/scriptforge/__License.xba | 25 + wizards/source/scriptforge/dialog.xlb | 6 + wizards/source/scriptforge/dlgConsole.xdl | 14 + wizards/source/scriptforge/dlgProgress.xdl | 11 + wizards/source/scriptforge/po/ScriptForge.pot | 975 +++++ wizards/source/scriptforge/po/en.po | 975 +++++ wizards/source/scriptforge/po/pt.po | 1141 +++++ .../source/scriptforge/python/ScriptForgeHelper.py | 317 ++ wizards/source/scriptforge/python/scriptforge.py | 2539 +++++++++++ wizards/source/scriptforge/script.xlb | 23 + wizards/source/sfdatabases/SF_Database.xba | 825 ++++ wizards/source/sfdatabases/SF_Register.xba | 195 + wizards/source/sfdatabases/__License.xba | 26 + wizards/source/sfdatabases/dialog.xlb | 3 + wizards/source/sfdatabases/script.xlb | 7 + wizards/source/sfdialogs/SF_Dialog.xba | 1111 +++++ wizards/source/sfdialogs/SF_DialogControl.xba | 2084 +++++++++ wizards/source/sfdialogs/SF_DialogListener.xba | 113 + wizards/source/sfdialogs/SF_Register.xba | 348 ++ wizards/source/sfdialogs/__License.xba | 26 + wizards/source/sfdialogs/dialog.xlb | 3 + wizards/source/sfdialogs/script.xlb | 9 + wizards/source/sfdocuments/SF_Base.xba | 993 +++++ wizards/source/sfdocuments/SF_Calc.xba | 4501 ++++++++++++++++++++ wizards/source/sfdocuments/SF_Chart.xba | 814 ++++ wizards/source/sfdocuments/SF_Document.xba | 1504 +++++++ wizards/source/sfdocuments/SF_DocumentListener.xba | 114 + wizards/source/sfdocuments/SF_Form.xba | 1535 +++++++ wizards/source/sfdocuments/SF_FormControl.xba | 1888 ++++++++ wizards/source/sfdocuments/SF_Register.xba | 546 +++ wizards/source/sfdocuments/SF_Writer.xba | 635 +++ wizards/source/sfdocuments/__License.xba | 26 + wizards/source/sfdocuments/dialog.xlb | 3 + wizards/source/sfdocuments/script.xlb | 14 + wizards/source/sfunittests/SF_Register.xba | 202 + wizards/source/sfunittests/SF_UnitTest.xba | 1818 ++++++++ wizards/source/sfunittests/__License.xba | 26 + wizards/source/sfunittests/dialog.xlb | 3 + wizards/source/sfunittests/script.xlb | 7 + wizards/source/sfwidgets/SF_Menu.xba | 590 +++ wizards/source/sfwidgets/SF_MenuListener.xba | 129 + wizards/source/sfwidgets/SF_PopupMenu.xba | 801 ++++ wizards/source/sfwidgets/SF_Register.xba | 184 + wizards/source/sfwidgets/__License.xba | 26 + wizards/source/sfwidgets/dialog.xlb | 3 + wizards/source/sfwidgets/script.xlb | 9 + wizards/source/standard/Module1.xba | 24 + wizards/source/standard/dialog.xlb | 3 + wizards/source/standard/script.xlb | 5 + wizards/source/template/Autotext.xba | 190 + wizards/source/template/Correspondence.xba | 303 ++ wizards/source/template/DialogStyles.xdl | 32 + wizards/source/template/ModuleAgenda.xba | 220 + wizards/source/template/Samples.xba | 168 + wizards/source/template/TemplateDialog.xdl | 46 + wizards/source/template/dialog.xlb | 7 + wizards/source/template/script.xlb | 8 + wizards/source/tools/Debug.xba | 253 ++ wizards/source/tools/DlgOverwriteAll.xdl | 34 + wizards/source/tools/Listbox.xba | 370 ++ wizards/source/tools/Misc.xba | 834 ++++ wizards/source/tools/ModuleControls.xba | 387 ++ wizards/source/tools/Strings.xba | 469 ++ wizards/source/tools/UCB.xba | 311 ++ wizards/source/tools/dialog.xlb | 5 + wizards/source/tools/script.xlb | 10 + wizards/source/tutorials/Functions.xba | 385 ++ wizards/source/tutorials/RoadMap.xba | 134 + wizards/source/tutorials/ShowInfoDialog.xba | 322 ++ wizards/source/tutorials/TutorialClose.xba | 32 + wizards/source/tutorials/TutorialCloseDialog.xdl | 31 + wizards/source/tutorials/TutorialCreator.xba | 27 + wizards/source/tutorials/TutorialOpen.xba | 113 + wizards/source/tutorials/TutorialOpenDialog.xdl | 38 + wizards/source/tutorials/TutorialsDialog.xdl | 43 + wizards/source/tutorials/dialog.xlb | 7 + wizards/source/tutorials/script.xlb | 10 + 195 files changed, 89405 insertions(+) create mode 100644 wizards/source/access2base/Application.xba create mode 100644 wizards/source/access2base/Collect.xba create mode 100644 wizards/source/access2base/CommandBar.xba create mode 100644 wizards/source/access2base/CommandBarControl.xba create mode 100644 wizards/source/access2base/Control.xba create mode 100644 wizards/source/access2base/DataDef.xba create mode 100644 wizards/source/access2base/Database.xba create mode 100644 wizards/source/access2base/Dialog.xba create mode 100644 wizards/source/access2base/DoCmd.xba create mode 100644 wizards/source/access2base/Event.xba create mode 100644 wizards/source/access2base/Field.xba create mode 100644 wizards/source/access2base/Form.xba create mode 100644 wizards/source/access2base/L10N.xba create mode 100644 wizards/source/access2base/Methods.xba create mode 100644 wizards/source/access2base/Module.xba create mode 100644 wizards/source/access2base/OptionGroup.xba create mode 100644 wizards/source/access2base/PropertiesGet.xba create mode 100644 wizards/source/access2base/PropertiesSet.xba create mode 100644 wizards/source/access2base/Property.xba create mode 100644 wizards/source/access2base/Python.xba create mode 100644 wizards/source/access2base/Recordset.xba create mode 100644 wizards/source/access2base/Root_.xba create mode 100644 wizards/source/access2base/SubForm.xba create mode 100644 wizards/source/access2base/TempVar.xba create mode 100644 wizards/source/access2base/Test.xba create mode 100644 wizards/source/access2base/Trace.xba create mode 100644 wizards/source/access2base/UtilProperty.xba create mode 100644 wizards/source/access2base/Utils.xba create mode 100644 wizards/source/access2base/_License.xba create mode 100644 wizards/source/access2base/acConstants.xba create mode 100644 wizards/source/access2base/access2base.py create mode 100644 wizards/source/access2base/dialog.xlb create mode 100644 wizards/source/access2base/dlgFormat.xdl create mode 100644 wizards/source/access2base/dlgTrace.xdl create mode 100644 wizards/source/access2base/script.xlb create mode 100644 wizards/source/config/dialog.xlc create mode 100644 wizards/source/config/script.xlc create mode 100644 wizards/source/configshare/dialog.xlc create mode 100644 wizards/source/configshare/script.xlc create mode 100644 wizards/source/depot/CommonLang.xba create mode 100644 wizards/source/depot/Currency.xba create mode 100644 wizards/source/depot/Depot.xba create mode 100644 wizards/source/depot/Dialog2.xdl create mode 100644 wizards/source/depot/Dialog3.xdl create mode 100644 wizards/source/depot/Dialog4.xdl create mode 100644 wizards/source/depot/Internet.xba create mode 100644 wizards/source/depot/Lang_de.xba create mode 100644 wizards/source/depot/Lang_en.xba create mode 100644 wizards/source/depot/Lang_es.xba create mode 100644 wizards/source/depot/Lang_fr.xba create mode 100644 wizards/source/depot/Lang_it.xba create mode 100644 wizards/source/depot/Lang_ja.xba create mode 100644 wizards/source/depot/Lang_ko.xba create mode 100644 wizards/source/depot/Lang_sv.xba create mode 100644 wizards/source/depot/Lang_tw.xba create mode 100644 wizards/source/depot/Lang_zh.xba create mode 100644 wizards/source/depot/dialog.xlb create mode 100644 wizards/source/depot/script.xlb create mode 100644 wizards/source/depot/tools.xba create mode 100644 wizards/source/euro/AutoPilotRun.xba create mode 100644 wizards/source/euro/Common.xba create mode 100644 wizards/source/euro/ConvertRun.xba create mode 100644 wizards/source/euro/DlgConvert.xdl create mode 100644 wizards/source/euro/DlgPassword.xdl create mode 100644 wizards/source/euro/Hard.xba create mode 100644 wizards/source/euro/Init.xba create mode 100644 wizards/source/euro/Protect.xba create mode 100644 wizards/source/euro/Soft.xba create mode 100644 wizards/source/euro/Writer.xba create mode 100644 wizards/source/euro/dialog.xlb create mode 100644 wizards/source/euro/script.xlb create mode 100644 wizards/source/formwizard/DBMeta.xba create mode 100644 wizards/source/formwizard/DlgFormDB.xdl create mode 100644 wizards/source/formwizard/FormWizard.xba create mode 100644 wizards/source/formwizard/Language.xba create mode 100644 wizards/source/formwizard/Layouter.xba create mode 100644 wizards/source/formwizard/develop.xba create mode 100644 wizards/source/formwizard/dialog.xlb create mode 100644 wizards/source/formwizard/script.xlb create mode 100644 wizards/source/formwizard/tools.xba create mode 100644 wizards/source/gimmicks/AutoText.xba create mode 100644 wizards/source/gimmicks/ChangeAllChars.xba create mode 100644 wizards/source/gimmicks/GetTexts.xba create mode 100644 wizards/source/gimmicks/ReadDir.xba create mode 100644 wizards/source/gimmicks/ReadFolderDlg.xdl create mode 100644 wizards/source/gimmicks/UserfieldDlg.xdl create mode 100644 wizards/source/gimmicks/Userfields.xba create mode 100644 wizards/source/gimmicks/dialog.xlb create mode 100644 wizards/source/gimmicks/readdirs.dlg create mode 100644 wizards/source/gimmicks/script.xlb create mode 100644 wizards/source/imagelists/imagelists.ilst create mode 100644 wizards/source/importwizard/API.xba create mode 100644 wizards/source/importwizard/DialogModul.xba create mode 100644 wizards/source/importwizard/FilesModul.xba create mode 100644 wizards/source/importwizard/ImportDialog.xdl create mode 100644 wizards/source/importwizard/Language.xba create mode 100644 wizards/source/importwizard/Main.xba create mode 100644 wizards/source/importwizard/dialog.xlb create mode 100644 wizards/source/importwizard/script.xlb create mode 100644 wizards/source/resources/resources_en_US.properties create mode 100644 wizards/source/scriptforge/SF_Array.xba create mode 100644 wizards/source/scriptforge/SF_Dictionary.xba create mode 100644 wizards/source/scriptforge/SF_Exception.xba create mode 100644 wizards/source/scriptforge/SF_FileSystem.xba create mode 100644 wizards/source/scriptforge/SF_L10N.xba create mode 100644 wizards/source/scriptforge/SF_Platform.xba create mode 100644 wizards/source/scriptforge/SF_PythonHelper.xba create mode 100644 wizards/source/scriptforge/SF_Region.xba create mode 100644 wizards/source/scriptforge/SF_Root.xba create mode 100644 wizards/source/scriptforge/SF_Services.xba create mode 100644 wizards/source/scriptforge/SF_Session.xba create mode 100644 wizards/source/scriptforge/SF_String.xba create mode 100644 wizards/source/scriptforge/SF_TextStream.xba create mode 100644 wizards/source/scriptforge/SF_Timer.xba create mode 100644 wizards/source/scriptforge/SF_UI.xba create mode 100644 wizards/source/scriptforge/SF_Utils.xba create mode 100644 wizards/source/scriptforge/_CodingConventions.xba create mode 100644 wizards/source/scriptforge/_ModuleModel.xba create mode 100644 wizards/source/scriptforge/__License.xba create mode 100644 wizards/source/scriptforge/dialog.xlb create mode 100644 wizards/source/scriptforge/dlgConsole.xdl create mode 100644 wizards/source/scriptforge/dlgProgress.xdl create mode 100644 wizards/source/scriptforge/po/ScriptForge.pot create mode 100644 wizards/source/scriptforge/po/en.po create mode 100644 wizards/source/scriptforge/po/pt.po create mode 100644 wizards/source/scriptforge/python/ScriptForgeHelper.py create mode 100644 wizards/source/scriptforge/python/scriptforge.py create mode 100644 wizards/source/scriptforge/script.xlb create mode 100644 wizards/source/sfdatabases/SF_Database.xba create mode 100644 wizards/source/sfdatabases/SF_Register.xba create mode 100644 wizards/source/sfdatabases/__License.xba create mode 100644 wizards/source/sfdatabases/dialog.xlb create mode 100644 wizards/source/sfdatabases/script.xlb create mode 100644 wizards/source/sfdialogs/SF_Dialog.xba create mode 100644 wizards/source/sfdialogs/SF_DialogControl.xba create mode 100644 wizards/source/sfdialogs/SF_DialogListener.xba create mode 100644 wizards/source/sfdialogs/SF_Register.xba create mode 100644 wizards/source/sfdialogs/__License.xba create mode 100644 wizards/source/sfdialogs/dialog.xlb create mode 100644 wizards/source/sfdialogs/script.xlb create mode 100644 wizards/source/sfdocuments/SF_Base.xba create mode 100644 wizards/source/sfdocuments/SF_Calc.xba create mode 100644 wizards/source/sfdocuments/SF_Chart.xba create mode 100644 wizards/source/sfdocuments/SF_Document.xba create mode 100644 wizards/source/sfdocuments/SF_DocumentListener.xba create mode 100644 wizards/source/sfdocuments/SF_Form.xba create mode 100644 wizards/source/sfdocuments/SF_FormControl.xba create mode 100644 wizards/source/sfdocuments/SF_Register.xba create mode 100644 wizards/source/sfdocuments/SF_Writer.xba create mode 100644 wizards/source/sfdocuments/__License.xba create mode 100644 wizards/source/sfdocuments/dialog.xlb create mode 100644 wizards/source/sfdocuments/script.xlb create mode 100644 wizards/source/sfunittests/SF_Register.xba create mode 100644 wizards/source/sfunittests/SF_UnitTest.xba create mode 100644 wizards/source/sfunittests/__License.xba create mode 100644 wizards/source/sfunittests/dialog.xlb create mode 100644 wizards/source/sfunittests/script.xlb create mode 100644 wizards/source/sfwidgets/SF_Menu.xba create mode 100644 wizards/source/sfwidgets/SF_MenuListener.xba create mode 100644 wizards/source/sfwidgets/SF_PopupMenu.xba create mode 100644 wizards/source/sfwidgets/SF_Register.xba create mode 100644 wizards/source/sfwidgets/__License.xba create mode 100644 wizards/source/sfwidgets/dialog.xlb create mode 100644 wizards/source/sfwidgets/script.xlb create mode 100644 wizards/source/standard/Module1.xba create mode 100644 wizards/source/standard/dialog.xlb create mode 100644 wizards/source/standard/script.xlb create mode 100644 wizards/source/template/Autotext.xba create mode 100644 wizards/source/template/Correspondence.xba create mode 100644 wizards/source/template/DialogStyles.xdl create mode 100644 wizards/source/template/ModuleAgenda.xba create mode 100644 wizards/source/template/Samples.xba create mode 100644 wizards/source/template/TemplateDialog.xdl create mode 100644 wizards/source/template/dialog.xlb create mode 100644 wizards/source/template/script.xlb create mode 100644 wizards/source/tools/Debug.xba create mode 100644 wizards/source/tools/DlgOverwriteAll.xdl create mode 100644 wizards/source/tools/Listbox.xba create mode 100644 wizards/source/tools/Misc.xba create mode 100644 wizards/source/tools/ModuleControls.xba create mode 100644 wizards/source/tools/Strings.xba create mode 100644 wizards/source/tools/UCB.xba create mode 100644 wizards/source/tools/dialog.xlb create mode 100644 wizards/source/tools/script.xlb create mode 100644 wizards/source/tutorials/Functions.xba create mode 100644 wizards/source/tutorials/RoadMap.xba create mode 100644 wizards/source/tutorials/ShowInfoDialog.xba create mode 100644 wizards/source/tutorials/TutorialClose.xba create mode 100644 wizards/source/tutorials/TutorialCloseDialog.xdl create mode 100644 wizards/source/tutorials/TutorialCreator.xba create mode 100644 wizards/source/tutorials/TutorialOpen.xba create mode 100644 wizards/source/tutorials/TutorialOpenDialog.xdl create mode 100644 wizards/source/tutorials/TutorialsDialog.xdl create mode 100644 wizards/source/tutorials/dialog.xlb create mode 100644 wizards/source/tutorials/script.xlb (limited to 'wizards/source') diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba new file mode 100644 index 000000000..74bb43558 --- /dev/null +++ b/wizards/source/access2base/Application.xba @@ -0,0 +1,1869 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const TRACEDEBUG = "DEBUG" ' To report values of variables +Global Const TRACEINFO = "INFO" ' To report any event +Global Const TRACEWARNING = "WARNING" ' To report some abnormal event +Global Const TRACEERRORS = "ERROR" ' To report user errors - Default value +Global Const TRACEFATAL = "FATAL" ' To report programmer errors - f.i. Wrong argument +Global Const TRACEABORT = "ABORT" ' To report Access2Base internal errors +Global Const TRACEANY = "===>" ' Always reported + ' ERRORs, FATALs and ABORTs are also displayed in a MsgBox (except on specific request) + ' FATALs and ABORTs interrupt the program execution + +Global Const ERRINIT = 1500 +Global Const ERRDBNOTCONNECTED = 1501 +Global Const ERRMISSINGARGUMENTS = 1502 +Global Const ERRWRONGARGUMENT = 1503 +Global Const ERRMAINFORM = 1504 +Global Const ERRMETHOD = 1505 +Global Const ERRFILEACCESS = 1506 +Global Const ERRFORMNOTIDENTIFIED = 1507 +Global Const ERRFORMNOTFOUND = 1508 +Global Const ERRFORMNOTOPEN = 1509 +Global Const ERRDFUNCTION = 1510 +Global Const ERROPENFORM = 1511 +Global Const ERRPROPERTY = 1512 +Global Const ERRPROPERTYVALUE = 1513 +Global Const ERRINDEXVALUE = 1514 +Global Const ERRCOLLECTION = 1515 +Global Const ERRPROPERTYNOTARRAY = 1516 +Global Const ERRCONTROLNOTFOUND = 1517 +Global Const ERRNOACTIVEFORM = 1518 +Global Const ERRDATABASEFORM = 1519 +Global Const ERRFOCUSINGRID = 1520 +Global Const ERRNOGRIDINFORM = 1521 +Global Const ERRFINDRECORD = 1522 +Global Const ERRSQLSTATEMENT = 1523 +Global Const ERROBJECTNOTFOUND = 1524 +Global Const ERROPENOBJECT = 1525 +Global Const ERRCLOSEOBJECT = 1526 +Global Const ERRMETHOD = 1527 +Global Const ERRACTION = 1528 +Global Const ERRSENDMAIL = 1529 +Global Const ERRFORMYETOPEN = 1530 +Global Const ERRPROPERTYINIT = 1531 +Global Const ERRFILENOTCREATED = 1532 +Global Const ERRDIALOGNOTFOUND = 1533 +Global Const ERRDIALOGUNDEFINED = 1534 +Global Const ERRDIALOGSTARTED = 1535 +Global Const ERRDIALOGNOTSTARTED = 1536 +Global Const ERRRECORDSETNODATA = 1537 +Global Const ERRRECORDSETCLOSED = 1538 +Global Const ERRRECORDSETRANGE = 1539 +Global Const ERRRECORDSETFORWARD = 1540 +Global Const ERRFIELDNULL = 1541 +Global Const ERROVERFLOW = 1542 +Global Const ERRNOTACTIONQUERY = 1543 +Global Const ERRNOTUPDATABLE = 1544 +Global Const ERRUPDATESEQUENCE = 1545 +Global Const ERRNOTNULLABLE = 1546 +Global Const ERRROWDELETED = 1547 +Global Const ERRRECORDSETCLONE = 1548 +Global Const ERRQUERYDEFDELETED = 1549 +Global Const ERRTABLEDEFDELETED = 1550 +Global Const ERRTABLECREATION = 1551 +Global Const ERRFIELDCREATION = 1552 +Global Const ERRSUBFORMNOTFOUND = 1553 +Global Const ERRWINDOW = 1554 +Global Const ERRCOMPATIBILITY = 1555 +Global Const ERRPRECISION = 1556 +Global Const ERRMODULENOTFOUND = 1557 +Global Const ERRPROCEDURENOTFOUND = 1558 + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const DBCONNECTBASE = 1 ' Connection from Base document (OpenConnection) +Global Const DBCONNECTFORM = 2 ' Connection from a database-aware form (OpenConnection) +Global Const DBCONNECTANY = 3 ' Connection from any document for data access only (OpenDatabase) + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const DBMS_UNKNOWN = 0 +Global Const DBMS_HSQLDB1 = 1 +Global Const DBMS_HSQLDB2 = 2 +Global Const DBMS_FIREBIRD = 3 +Global Const DBMS_MSACCESS2003 = 4 +Global Const DBMS_MSACCESS2007 = 5 +Global Const DBMS_MYSQL = 6 +Global Const DBMS_POSTGRES = 7 +Global Const DBMS_SQLITE = 8 + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const COLLALLDIALOGS = "ALLDIALOGS" +Global Const COLLALLFORMS = "ALLFORMS" +Global Const COLLALLMODULES = "ALLMODULES" +Global Const COLLCOMMANDBARS = "COMMANDBARS" +Global Const COLLCOMMANDBARCONTROLS = "COMMANDBARCONTROLS" +Global Const COLLCONTROLS = "CONTROLS" +Global Const COLLFORMS = "FORMS" +Global Const COLLFIELDS = "FIELDS" +Global Const COLLPROPERTIES = "PROPERTIES" +Global Const COLLQUERYDEFS = "QUERYDEFS" +Global Const COLLRECORDSETS = "RECORDSETS" +Global Const COLLTABLEDEFS = "TABLEDEFS" +Global Const COLLTEMPVARS = "TEMPVARS" + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const OBJAPPLICATION = "APPLICATION" +Global Const OBJCOLLECTION = "COLLECTION" +Global Const OBJCOMMANDBAR = "COMMANDBAR" +Global Const OBJCOMMANDBARCONTROL = "COMMANDBARCONTROL" +Global Const OBJCONTROL = "CONTROL" +Global Const OBJDATABASE = "DATABASE" +Global Const OBJDIALOG = "DIALOG" +Global Const OBJEVENT = "EVENT" +Global Const OBJFIELD = "FIELD" +Global Const OBJFORM = "FORM" +Global Const OBJMODULE = "MODULE" +Global Const OBJOPTIONGROUP = "OPTIONGROUP" +Global Const OBJPROPERTY = "PROPERTY" +Global Const OBJQUERYDEF = "QUERYDEF" +Global Const OBJRECORDSET = "RECORDSET" +Global Const OBJSUBFORM = "SUBFORM" +Global Const OBJTABLEDEF = "TABLEDEF" +Global Const OBJTEMPVAR = "TEMPVAR" + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const CTLCONTROL = "CONTROL" ' ClassId +Global Const CTLCHECKBOX = "CHECKBOX" ' 5 +Global Const CTLCOMBOBOX = "COMBOBOX" ' 7 +Global Const CTLCOMMANDBUTTON = "COMMANDBUTTON" ' 2 +Global Const CTLCURRENCYFIELD = "CURRENCYFIELD" ' 18 +Global Const CTLDATEFIELD = "DATEFIELD" ' 15 +Global Const CTLFILECONTROL = "FILECONTROL" ' 12 +Global Const CTLFIXEDTEXT = "FIXEDTEXT" ' 10 +Global Const CTLGRIDCONTROL = "GRIDCONTROL" ' 11 +Global Const CTLGROUPBOX = "GROUPBOX" ' 8 +Global Const CTLHIDDENCONTROL = "HIDDENCONTROL" ' 13 +Global Const CTLIMAGEBUTTON = "IMAGEBUTTON" ' 4 +Global Const CTLIMAGECONTROL = "IMAGECONTROL" ' 14 +Global Const CTLLISTBOX = "LISTBOX" ' 6 +Global Const CTLNAVIGATIONBAR = "NAVIGATIONBAR" ' 22 +Global Const CTLNUMERICFIELD = "NUMERICFIELD" ' 17 +Global Const CTLPATTERNFIELD = "PATTERNFIELD" ' 19 +Global Const CTLRADIOBUTTON = "RADIOBUTTON" ' 3 +Global Const CTLSCROLLBAR = "SCROLLBAR" ' 20 +Global Const CTLSPINBUTTON = "SPINBUTTON" ' 21 +Global Const CTLTEXTFIELD = "TEXTFIELD" ' 9 +Global Const CTLTIMEFIELD = "TIMEFIELD" ' 16 +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const CTLFORMATTEDFIELD = "FORMATTEDFIELD" ' 9 (idem TextField) +Global Const CTLFIXEDLINE = "FIXEDLINE" ' 24 (forced) +Global Const CTLPROGRESSBAR = "PROGRESSBAR" ' 23 (forced) +Global Const CTLSUBFORM = "SUBFORMCONTROL" ' None +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const CTLPARENTISFORM = "FORM" +Global Const CTLPARENTISDIALOG = "DIALOG" +Global Const CTLPARENTISSUBFORM = "SUBFORM" +Global Const CTLPARENTISGRID = "GRID" +Global Const CTLPARENTISGROUP = "OPTIONGROUP" + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const MODDOCUMENT = "DOCUMENT" +Global Const MODGLOBAL = "GLOBAL" + +REM ----------------------------------------------------------------------------------------------------------------------- +Type DocContainer + Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj + Active As Boolean + DbConnect As Integer ' DBCONNECTxxx constants + URL As String + DbContainers() As Variant ' One entry by (data-aware) form +End Type + +Type DbContainer + FormName As String ' name of data-aware form + Database As Object ' Database type +End Type + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- Next variable is initialized to empty at each macro execution start --- +REM --- Items in both lists correspond one by one --- +Public vFormNamesList As Variant ' (0) Buffer of hierarchical form names => "\;" separated values + ' (1) Buffer of persistent form names => "\;" separated values + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AllDialogs(ByVal Optional pvIndex As Variant) As Variant +' Return either a Collection or a Dialog object +' The dialogs are selected only if library is loaded + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "AllDialogs" + Utils._SetCalledSub(cstThisSub) + +Dim iMode As Integer, vDialogs() As Variant, i As Integer, j As Integer, iCount As Integer +Dim oMacLibraries As Object, vAllDialogs As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean +Dim oLibDialog As Object, sLibrary As String, oDocLibraries As Object, bLocalStorage As Boolean +Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object +Dim vCurrentDocument As Variant +Const cstCount = 0 +Const cstByIndex = 1 +Const cstByName = 2 +Const cstSepar = "!" + + If IsMissing(pvIndex) Then + iMode = cstCount + Else + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex + End If + + Set vAllDialogs = Nothing + + Set vCurrentDocument = Nothing + If Not IsNull(_A2B_.CurrentDocument) Then + Set vCurrentDocument = _A2B_.CurrentDocument.Document + ElseIf Not IsNull(ThisComponent) Then + Set vCurrentDocument = ThisComponent + End If + If IsNull(vCurrentDocument) Then + Set oDocLibraries = Nothing + vDocLibraries = Array() + Else + Set oDocLibraries = vCurrentDocument.DialogLibraries + vDocLibraries = oDocLibraries.getElementNames() + End If + Set oMacLibraries = GlobalScope.DialogLibraries + vMacLibraries = oMacLibraries.getElementNames() + 'Remove Access2Base from the list + If _A2B_.ExcludeA2B Then + For i = 0 To UBound(vMacLibraries) + If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = "" + Next i + End If + vMacLibraries = Utils._TrimArray(vMacLibraries) + + If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library + Set vAllDialogs = New Collect + Set vAllDialogs._This = vAllDialogs + vAllDialogs._CollType = COLLALLDIALOGS + vAllDialogs._Count = 0 + Goto Exit_Function + End If + + vNames = Array() + iCount = 0 + For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1 + bFound = False + If i <= UBound(vDocLibraries) Then + sLibrary = vDocLibraries(i) + bLocalStorage = True + Set oDocMacLib = oDocLibraries + ' Sometimes library not loaded as should ?? + If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary) + Else + sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1) + bLocalStorage = False + Set oDocMacLib = oMacLibraries + End If + If oDocMacLib.IsLibraryLoaded(sLibrary) Then + Set oLibrary = oDocMacLib.getByName(sLibrary) + If oLibrary.hasElements() Then + vDialogs = oLibrary.getElementNames() + Select Case iMode + Case cstCount + iCount = iCount + UBound(vDialogs) + 1 + Case cstByIndex, cstByName + For j = 0 To UBound(vDialogs) + If iMode = cstByIndex Then + If pvIndex = iCount Then bFound = True + iCount = iCount + 1 + Else + If UCase(pvIndex) = UCase(vDialogs(j)) Then bFound = True + End If + If bFound Then + Set oLibDialog = oLibrary.getByName(vDialogs(j)) ' Create Dialog object + Exit For + End If + Next j + End Select + End If + End If + If bFound Then Exit For + Next i + + If iMode = cstCount Then + Set vAllDialogs = New Collect + Set vAllDialogs._This = vAllDialogs + vAllDialogs._CollType = COLLALLDIALOGS + vAllDialogs._Count = iCount + Else + If Not bFound Then + If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found + End If + Set vAllDialogs = New Dialog + With vAllDialogs + ._This = vAllDialogs + ._Name = vDialogs(j) + ._Shortcut = "Dialogs!" & vDialogs(j) + Set ._Dialog = oLibDialog + ._Library = sLibrary + ._Storage = Iif(bLocalStorage, "DOCUMENT", "GLOBAL") + End With + End If + +Exit_Function: + Set AllDialogs = vAllDialogs + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Not_Found: + TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex) + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vDialogs = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set vDialogs = Nothing + GoTo Exit_Function +End Function ' AllDialogs V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AllForms(ByVal Optional pvIndex As Variant) As Variant +' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string) +' Easiest use for standalone forms: AllForms(0) +' If no argument, return a Collection type + +Const cstThisSub = "AllForms" +Dim iIndex As Integer, vReturn As Variant +Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object +Dim ofForm As Object +Dim vAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean +Const cstSeparator = "\;" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Set vReturn = Nothing + + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + Select Case VarType(pvIndex) + Case vbString + iIndex = -1 + Case Else + iIndex = pvIndex + End Select + End If + + iCurrentDoc = _A2B_.CurrentDocIndex() + If iCurrentDoc >= 0 Then + vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) + Else + Goto Exit_Function + End If + +' Load complete list of hierarchical and persistent names when Base document + If vCurrentDoc.DbConnect = DBCONNECTBASE Then vAllForms = _GetAllHierarchicalNames() + +' Process when NO ARGUMENT + If IsMissing(pvIndex) Then ' No argument + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLALLFORMS + If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = UBound(vAllForms) + 1 + Set vReturn = oCounter + Goto Exit_Function + End If + +' Process when ARGUMENT = STRING or INDEX => Initialize form object + Set ofForm = New Form + Set ofForm._This = ofForm + Select Case vCurrentDoc.DbConnect + Case DBCONNECTBASE + ofForm._DocEntry = 0 + ofForm._DbEntry = 0 + If iIndex= -1 Then ' String argument + vName = Utils._InList(Utils._Trim(pvIndex), vAllForms, True) + If vName = False Then Goto Trace_Not_Found + ofForm._Initialize(vName) + Else + If iIndex > UBound(vAllForms) Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense + ofForm._Initialize(vAllForms(iIndex)) + End If + Case DBCONNECTFORM + With vCurrentDoc + If iIndex = -1 Then + bFound = False + For i = 0 To UBound(vCurrentDoc.DbContainers) + Set oDatabase = vCurrentDoc.DbContainers(i).Database + If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then + bFound = True + ofForm._DbEntry = i + Exit For + End If + Next i + If Not bFound Then Goto Trace_Not_Found + ElseIf iIndex < 0 Or iIndex > UBound(vCurrentDoc.DbContainers) Then + Goto Trace_Error_Index + Else + ofForm._DbEntry = iIndex + Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database + End If + End With + vName = oDatabase.FormName + ofForm._DocEntry = iCurrentDoc + ofForm._Initialize(vName) + End Select + + Set vReturn = ofForm + +Exit_Function: + Set AllForms = vReturn + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Not_Found: + TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, , pvIndex) + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vReturn = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set vReturn = Nothing + GoTo Exit_Function +End Function ' AllForms V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AllModules(ByVal Optional pvIndex As Variant, ByVal Optional pbAllModules As Boolean) As Variant +' Return either a Collection or a Module object +' The modules are selected only if library is loaded +' (UNPUBLISHED) pbAllModules = False collects only the modules located in the currently open document + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "AllModules" + Utils._SetCalledSub(cstThisSub) + +Dim iMode As Integer, vModules() As Variant, i As Integer, j As Integer, iCount As Integer +Dim oMacLibraries As Object, vAllModules As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean +Dim sScript As String, sLibrary As String, oDocLibraries As Object, sStorage As String +Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object +Const cstCount = 0, cstByIndex = 1, cstByName = 2 +Const cstDot = "." + + If IsMissing(pvIndex) Then + iMode = cstCount + Else + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + If VarType(pvIndex) = vbString Then + iMode = cstByName + ' Determine full name STORAGE.LIBRARY.MODULE + vNames = Split(pvIndex, cstDot) + If UBound(vNames) = 2 Then + ElseIf UBound(vNames) = 1 Then + pvIndex = MODDOCUMENT & cstDot & pvIndex + ElseIf UBound(vNames) = 0 Then + pvIndex = MODDOCUMENT & cstDot & "STANDARD" & cstDot & pvIndex + Else + GoTo Trace_Not_Found + End If + Else + iMode = cstByIndex + End If + End If + + If IsMissing(pbAllModules) Then pbAllModules = True + If Not Utils._CheckArgument(pbAllModules, 2, vbBoolean) Then Goto Exit_Function + + Set vAllModules = Nothing + + Set oDocLibraries = _A2B_.CurrentDocument.Document.BasicLibraries ' ThisComponent.BasicLibraries + vDocLibraries = oDocLibraries.getElementNames() + If pbAllModules Then + Set oMacLibraries = GlobalScope.BasicLibraries + vMacLibraries = oMacLibraries.getElementNames() + 'Remove Access2Base from the list + If _A2B_.ExcludeA2B Then + For i = 0 To UBound(vMacLibraries) + If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = "" + Next i + End If + vMacLibraries = Utils._TrimArray(vMacLibraries) + End If + + If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library + Set vAllModules = New Collect + Set vAllModules._This = vAllModules + vAllModules._CollType = COLLALLMODULES + vAllModules._Count = 0 + Goto Exit_Function + End If + + iCount = 0 + For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1 + bFound = False + If i <= UBound(vDocLibraries) Then + sLibrary = vDocLibraries(i) + sStorage = MODDOCUMENT + Set oDocMacLib = oDocLibraries + ' Sometimes library not loaded as should ?? + If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary) + Else + sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1) + sStorage = MODGLOBAL + Set oDocMacLib = oMacLibraries + End If + If oDocMacLib.IsLibraryLoaded(sLibrary) Then + Set oLibrary = oDocMacLib.getByName(sLibrary) + If oLibrary.hasElements() Then + vModules = oLibrary.getElementNames() + Select Case iMode + Case cstCount + iCount = iCount + UBound(vModules) + 1 + Case cstByIndex, cstByName + For j = 0 To UBound(vModules) + If iMode = cstByIndex Then + If pvIndex = iCount Then bFound = True + iCount = iCount + 1 + Else + If UCase(pvIndex) = UCase(sStorage & cstDot & sLibrary & cstDot & vModules(j)) Then bFound = True + End If + If bFound Then + sScript = oLibrary.getByName(vModules(j)) ' Initiate Module object + iCount = i + Exit For + End If + Next j + End Select + End If + End If + If bFound Then Exit For + Next i + + If iMode = cstCount Then + Set vAllModules = New Collect + Set vAllModules._This =vAllModules + vAllModules._CollType = COLLALLMODULES + vAllModules._Count = iCount + Else + If Not bFound Then + If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found + End If + Set vAllModules = New Module + Set vAllModules._This = vAllModules + vAllModules._Name = vModules(j) + vAllModules._LibraryName = sLibrary + Set vAllModules._Library = oLibrary + vAllModules._Storage = sStorage + vAllModules._Script = sScript + vAllModules._Initialize() + End If + +Exit_Function: + Set AllModules = vAllModules + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Not_Found: + TraceError(TRACEFATAL, ERRMODULENOTFOUND, Utils._CalledSub(), 0, , pvIndex) + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vModules = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set vModules = Nothing + GoTo Exit_Function +End Function ' AllModules V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub CloseConnection () + +' Close all connections established by current document to free memory. +' - if Base document => close the one concerned database connection +' - if non-Base documents => close the connections of each individual standalone form + + If IsEmpty(_A2B_) Then Goto Exit_Sub + +Const cstThisSub = "CloseConnection" + Utils._SetCalledSub(cstThisSub) + + Call _A2B_.CloseConnection() + +Exit_Sub: + Utils._ResetCalledSub(cstThisSub) + Exit Sub +End Sub ' CloseConnection V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CommandBars(Optional ByVal pvIndex As Variant, Optional ByRef poWindow As Object) As Variant +' Return an object of type CommandBar indicated by its index or its name (CASE-INSENSITIVE string) +' If no pvIndex argument, return a Collection type +' (Unpublished) With poWindow, force the frame in which toolbars are detected + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBars" + Utils._SetCalledSub(cstThisSub) + +Dim iObjectsCount As Integer, sObjectName As String, oObject As Object +Dim oWindow As Object, iWindowType As Integer +Dim i As Integer, j As Integer, k As Integer, bFound As Boolean +Dim sSupportedModules() As Variant, vModules() As Variant, oModuleUI As Object +Dim oToolbar As Object, sToolbarName As String, vUIElements() As Variant, sToolbarFullName As String, iBuiltin As Integer + +Const cstCustom = "CUSTOM" + + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + iObjectsCount = 0 + bFound = False + + If IsMissing(poWindow) Then Set oWindow = _SelectWindow() Else Set oWindow = poWindow + If IsNull(oWindow.Frame) Then Goto Trace_WindowError + + ' List of 21 modules + vModules = CreateUnoService("com.sun.star.frame.ModuleManager").getElementNames() + + iWindowType = oWindow.WindowType + Select Case iWindowType ' Supported window types only + Case acForm + sSupportedModules = Array( "com.sun.star.sdb.FormDesign" ) + Case acBasicIDE + sSupportedModules = Array( "com.sun.star.script.BasicIDE" ) + Case acDatabaseWindow + sSupportedModules = Array( "com.sun.star.sdb.OfficeDatabaseDocument" ) + Case acReport + sSupportedModules = Array( "com.sun.star.sdb.TextReportDesign" ) + Case acDocument + Select Case oWindow.DocumentType + Case docCalc : sSupportedModules = Array( "com.sun.star.sheet.SpreadsheetDocument" ) + Case docWriter : sSupportedModules = Array( "com.sun.star.text.TextDocument" ) + Case docImpress : sSupportedModules = Array( "com.sun.star.presentation.PresentationDocument" ) + Case docDraw : sSupportedModules = Array( "com.sun.star.drawing.DrawingDocument" ) + Case docMath : sSupportedModules = Array( "com.sun.star.formula.FormulaProperties" ) + Case Else : sSupportedModules = Array() + End Select + Case acTable, acQuery + sSupportedModules = Array( "com.sun.star.sdb.DataSourceBrowser" _ + , "com.sun.star.sdb.TableDataView" _ + ) + Case acDiagram + sSupportedModules = Array( "com.sun.star.sdb.RelationDesign" ) + Case acWelcome + sSupportedModules = Array( "com.sun.star.frame.StartModule" ) + Case Else + sSupportedModules = Array() + End Select + + ' Find all standard and custom toolbars stored in LibO/AOO Base + Set oModuleUI = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier") + For k = 0 To UBound(vModules) + For j = 0 To UBound(sSupportedModules) + iBuiltin = 1 ' Default = builtin + If vModules(k) = sSupportedModules(j) Then ' Supported modules only + Set oToolbar = oModuleUI.getUIConfigurationManager(vModules(k)) + vUIElements() = oToolbar.getUIElementsInfo(0) + For i = 0 To UBound(vUIElements) + sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL") + sToolbarName = Split(sToolbarFullName, "/")(2) + If _IsLeft(UCase(sToolbarName), UCase(cstCustom)) Then + sToolbarName = _GetPropertyValue(vUIElements(i), "UIName") + iBuiltin = 2 + End If + + iObjectsCount = iObjectsCount + 1 + Select Case True + Case IsMissing(pvIndex) + Case VarType(pvIndex) = vbString + If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True + Case Else + If pvIndex < 0 Then Goto Trace_IndexError + If pvIndex = iObjectsCount - 1 Then bFound = True + End Select + + If bFound Then + Set oObject = _NewCommandBar(vModules(k), sToolbarName, sToolbarFullName, iBuiltin) + Set oObject._Window = oWindow.Frame + Set oObject._Toolbar = oToolbar + Goto Exit_Function + End If + Next i + End If + Next j + Next k + + ' Find all (not builtin) toolbars stored in current document (typically forms) + iBuiltin = 3 ' Stored in form itself + Set oToolbar = oWindow.Frame.Controller.Model.getUIConfigurationManager + vUIElements() = oToolbar.getUIElementsInfo(0) + For i = 0 To UBound(vUIElements) + sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL") + sToolbarName = _GetPropertyValue(vUIElements(i), "UIName") + iObjectsCount = iObjectsCount + 1 + Select Case True + Case IsMissing(pvIndex) + Case VarType(pvIndex) = vbString + If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True + Case Else + If pvIndex = iObjectsCount - 1 Then bFound = True + End Select + If bFound Then + Set oObject = _NewCommandBar("", sToolbarName, sToolbarFullName, iBuiltin) + Set oObject._Window = oWindow.Frame + Set oObject._Toolbar = oToolbar + Goto Exit_Function + End If + Next i + + ' MISSING : CUSTOM POPUPS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLCOMMANDBARS + oObject._Count = iObjectsCount + Case VarType(pvIndex) = vbString + Goto Trace_NotFound + Case Else ' pvIndex is numeric + Goto Trace_IndexError + End Select + +Exit_Function: + Set CommandBars = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("COMMANDBAR"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_WindowError: + TraceError(TRACEFATAL, ERRWINDOW, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' CommandBars V1,3,0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(ByVal Optional pvObject As Variant, Optional ByVal pvIndex As Variant) As Variant +' Return an object of type Control indicated by either its index (integer) or its name (CASE-INSENSITIVE string) +' The 1st argument pvObject can be either +' an object of type FORM (1) +' a main form name as string +' an object of type SUBFORM (2) +' The Form property in the returned variant contains a SUBFORM type +' an object of type CONTROL and subtype GRIDCONTROL (3) +' an object of type OPTIONGROUP (4) 2nd argument, if any, must be numeric +' If no pvIndex argument, return a Collection type + +If _ErrorHandler() Then On Local Error Goto Error_Function +Dim vObject As Object +Const cstThisSub = "Controls" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObject) Then Call _TraceArguments() + If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments() + Controls = EMPTY + + If VarType(pvObject) = vbString Then + Set vObject = Forms(pvObject) + If IsNull(vObject) Then Goto Exit_Function + Else + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM, OBJOPTIONGROUP, CTLGRIDCONTROL)) Then Goto Exit_Function + Set vObject = pvObject + End If + + If IsMissing(pvIndex) Then + Controls = vObject.Controls() + Else + If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function + Controls = vObject.Controls(pvIndex) + End If + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEERROR, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Controls V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties + +Const cstThisSub = "CurrentDb" + Utils._SetCalledSub(cstThisSub) + + Set CurrentDb = Nothing + If IsEmpty(_A2B_) Then GoTo Exit_Function + Set CurrentDb = _A2B_.CurrentDb() + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentUser() As String + +Dim oPath As Object, sUser As String + + Set oPath = CreateUnoService("com.sun.star.util.PathSubstitution") + sUser = oPath.getSubstituteVariableValue("$(username)") ' New since LibreOffice 5.2 + CurrentUser = sUser + +End Function ' CurrentUser V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DAvg( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return average of scope +Const cstThisSub = "DAvg" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DAvg + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DCount( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return # of occurrences of scope +Const cstThisSub = "DCount" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DLookup( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + +' Return a value within a table + 'Arguments: psExpr: an SQL expression + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + 'Return: Value of the psExpr if found, else Null. + 'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html + 'Examples: + ' 1. To find the last value, include DESC in the OrderClause, e.g.: + ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC") + ' 2. To find the lowest non-null value of a field, use the Criteria, e.g.: + ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname") + +Const cstThisSub = "DLookup" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _ + , Iif(IsMissing(pvCriteria), "", pvCriteria) _ + , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _ + ) + Utils._ResetCalledSub(cstThisSub) +End Function ' DLookup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMax( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return maximum of scope +Const cstThisSub = "DMax" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMax + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMin( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return minimum of scope +Const cstThisSub = "DMin" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMin + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDev( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "DStDev" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDev + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDevP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "DStDevP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDevP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DSum( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return sum of scope +Const cstThisSub = "DSum" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DSum + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVar( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "DVar" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVarP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "DVarP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVarP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Events(Optional poEvent As Variant) As Variant +' Return an event object corresponding with actual event + +Dim vEvent As Variant + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Events" + Utils._SetCalledSub(cstThisSub) + + Set vEvent = Nothing + If IsMissing(poEvent) Then Goto Exit_Function + If IsNull(poEvent) Then Goto Exit_Function + + If Not Utils._CheckArgument(poEvent, 1, vbObject, , False) Then Goto Exit_Function ' No error handling in CheckArgument + If Not Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error + Set vEvent = New Event + vEvent._Initialize(poEvent) + +Exit_Function: + Set Events = vEvent + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEWARNING, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + ' Errors are not displayed to avoid display infinite cycling + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent))) + Set vEvent = Nothing + Goto Exit_Function +End Function ' Events V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Forms(ByVal Optional pvIndex As Variant) As Variant +' Return an object of type Form indicated by either its index (integer) or its name (NOT CASE-SENSITIVE string) +' The concerned form must be loaded. +' If no argument, return a Collection type + +Const cstThisSub = "Forms" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim ofForm As Object, oCounter As Variant, vForms As Variant, oIndex As Object + Set vForms = Nothing + +Dim iCount As Integer + If IsMissing(pvIndex) Then + iCount = Application._CountOpenForms() + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLFORMS + oCounter._Count = iCount + Forms = oCounter + Exit Function + Else + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + Select Case VarType(pvIndex) + Case vbString + Set ofForm = Application.AllForms(Utils._Trim(pvIndex)) + Case Else + iCount = Application._CountOpenForms() + If iCount <= pvIndex Then Goto Trace_Error_Index + Set ofForm = Application._CountOpenForms(pvIndex) + End Select + + If IsNull(ofForm) Then Goto Trace_Error + If ofForm.IsLoaded Then + Set vForms = ofForm + Else + Set vForms = Nothing + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , ofForm._Name) + Goto Exit_Function + End If + +Exit_Function: + Set Forms = vForms + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvIndex)) + Set vForms = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vForms = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Forms V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getObject(Optional pvShortcut As Variant) As Variant +' Return the object described by pvShortcut ignoring its final property +' Example: "Forms!myForm!myControl.myProperty" => Controls(Forms("myForm"), "myControl")) + +Const cstEXCLAMATION = "!" +Const cstDOT = "." + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "getObject" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvShortcut) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvShortcut, 1, vbString) Then Goto Exit_Function + +Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String +Dim sComponents() As String, sSubComponents() As String, sDialog As String +Dim oDoc As Object + Set vCurrentObject = Nothing + sComponents = Split(Trim(pvShortcut), cstEXCLAMATION) + If UBound(sComponents) = 0 Then Goto Trace_Error + If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS", "TEMPVARS")) Then Goto Trace_Error + If sComponents(1) = "0" Or Left(sComponents(1), 2) = "0." Then + Set oDoc = _A2B_.CurrentDocument() + If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error + End If + + sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT) + sComponents(UBound(sComponents)) = sSubComponents(0) ' Ignore final property, if any + + Set vCurrentObject = New Collect + Set vCurrentObject._This = vCurrentObject + Select Case UCase(sComponents(0)) + Case "FORMS" : vCurrentObject._CollType = COLLFORMS + Case "DIALOGS" : vCurrentObject._CollType = COLLALLDIALOGS + Case "TEMPVARS" : vCurrentObject._CollType = COLLTEMPVARS + End Select + For iCurrentIndex = 1 To UBound(sComponents) ' Start parsing ... + sSubComponents = Split(sComponents(iCurrentIndex), cstDOT) + sComponents(iCurrentIndex) = Utils._Trim(sSubComponents(0)) + Select Case UBound(sSubComponents) + Case 0 + sCurrentProperty = "" + Case 1 + sCurrentProperty = sSubComponents(1) + Case Else + Goto Trace_Error + End Select + Select Case vCurrentObject._Type + Case OBJCOLLECTION + Select Case vCurrentObject._CollType + Case COLLFORMS + vCurrentObject = Application.AllForms(sComponents(iCurrentIndex)) + Case COLLALLDIALOGS + sDialog = UCase(sComponents(iCurrentIndex)) + vCurrentObject = Application.AllDialogs(sDialog) + If Not vCurrentObject.IsLoaded Then Goto Trace_Error + Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog) + Case COLLTEMPVARS + If UBound(sComponents) > 1 Then Goto Trace_Error + vCurrentObject = Application.TempVars(sComponents(1)) + 'Case Else + End Select + Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG + vCurrentObject = vCurrentObject.Controls(sComponents(iCurrentIndex)) + End Select + If sCurrentProperty <> "" Then vCurrentObject = vCurrentObject.getProperty(sCurrentProperty) + Next iCurrentIndex + + Set getObject = vCurrentObject + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvShortcut)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' getObject V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getValue(Optional pvObject As Variant) As Variant +' getValue also interprets shortcut strings !! +Dim vItem As Variant, sProperty As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getValue") + If VarType(pvObject) = vbString Then + Utils._SetCalledSub("getValue") + Set vItem = getObject(pvObject) + sProperty = Utils._FinalProperty(pvObject) + If sProperty = "" Then sProperty = "Value" ' Default value if final property in shortcut is absent + getValue = vItem.getProperty(sproperty) + Utils._ResetCalledSub("getValue") + Else + Set vItem = pvObject + getValue = vItem.getProperty("Value") + End If +End Function ' getValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Function HtmlEncode(ByVal pvString As Variant, ByVal Optional pvLength As Variant) As String +' Converts a string to an HTML-encoded string. + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "HtmlEncode" + Utils._SetCalledSub(cstThisSub) + + HtmlEncode = "" + +Dim sOutput As String, l As Long, lLength As Long + If IsMissing(pvLength) Then pvLength = 0 + If Not Utils._CheckArgument(pvString, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvLength, 1, _AddNumeric()) Then Goto Exit_Function + + sOutput = "" + lLength = CLng(pvLength) + If Len(pvString) > 0 Then + For l = 1 To Len(pvString) + If lLength > 0 And Len(sOutput) > lLength Then Exit For + sOutput = sOutput & Utils._UTF8Encode(Mid(pvString, l, 1)) + Next l + End If + + HtmlEncode = sOutput + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' HtmlEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenConnection ( _ + Optional pvComponent As Variant _ + , ByVal Optional pvUser As Variant _ + , ByVal Optional pvPassword As Variant _ + ) As Object + +' Establish connection with the database designated in the currently open front-end (.odb) document +' Call template: +' Call OpenConnection(ThisDatabaseDocument[, "", ""]) +' Call stored in the OpenDocument event of the front-end database document +'OR +' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms +' Call template: +' Call OpenConnection(ThisComponent[, "", ""]) +' Call stored in the OpenDocument event of the document +' +' User and Password arguments are obsolete (still tolerated) +' - because no mean has been found to connect protected db from .odb via API +' - because having multiple forms with multiple db's and multiple passwords is meaningless + +Dim oComponent As Object, oForms As Object, iCurrent As Integer +Dim i As Integer, bFound As Boolean +Dim vCurrentDoc() As Variant +Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object +Dim sDatabaseURL As String, oHandler As Object +Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant +Dim sFormName As String + + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session + Set OpenConnection = Nothing + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OpenConnection" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvComponent) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function + Set oComponent = pvComponent + If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(1, oComponent)) + Exit Function + End If + If IsMissing(pvUser) Then pvUser = "" + If IsMissing(pvPassword) Then pvPassword = "" + If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function + + If Not IsArray(_A2B_.CurrentDoc) Then + vCurrentDoc() = Array() + Redim vCurrentDoc(0 To 0) ' Create at least one entry for database document + Else + vCurrentDoc() = _A2B_.CurrentDoc() + End If + + ' Find index of entry to use for new connection + With oComponent + Select Case .ImplementationName + Case "com.sun.star.comp.dba.ODatabaseDocument" + iCurrent = 0 + Case Else ' "SwXTextDocument", "ScModelObj" + If UBound(vCurrentDoc) <= 0 Then ' First Calc or Writer during current session + iCurrent = 1 + Else ' Search entry already used earlier by same component + bFound = False + For i = 1 To UBound(vCurrentDoc) + If Not IsEmpty(vCurrentDoc(i)) Then + If vCurrentDoc(i).Active And vCurrentDoc(i).URL = .URL Then + iCurrent = i + bFound = True + Exit For + End If + End If + Next i + End If + If Not bFound Then + iCurrent = UBound(vCurrentDoc) + 1 ' No entry found, increment array + ReDim Preserve vCurrentDoc(0 To iCurrent) + End If + End Select + End With + + ' Initialize future entry + Set vDocContainer = New DocContainer + Set vDocContainer.Document = oComponent + vDocContainer.Active = True + vDocContainer.URL = oComponent.URL + ' Initialize each DbContainer entry + vDbContainers() = Array() + TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) + Select Case oComponent.ImplementationName + Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments + vDbContainer = New DbContainer + vDbContainer.FormName = "" + Set vDbContainer.Database = New Database + Set vDbContainer.Database._This = vDbContainer.Database + With vDbContainer.Database + If Not oComponent.CurrentController.IsConnected Then + Set oHandler = createUnoService("com.sun.star.sdb.InteractionHandler") + Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler) + oComponent.CurrentController.connect() + Else + Set .Connection = oComponent.CurrentController.ActiveConnection + End If + vDocContainer.DbConnect = DBCONNECTBASE + ._DbConnect = DBCONNECTBASE + Set .MetaData = .Connection.MetaData + ._LoadMetadata() + If .MetaData.DatabaseProductName = "MySQL" Then + ._ReadOnly = .MetaData.isReadOnly() + Else + ._ReadOnly = .Connection.isReadOnly() ' Always True in Mysql ?? + End If + Set .Document = oComponent + .Title = oComponent.Title + .URL = vDocContainer.URL + .Location = oComponent.Location + ReDim vDbContainers(0 To 0) + Set vDbContainers(0) = vDbContainer + TraceLog(TRACEANY, .Version, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False) + End With + Case Else + Set oForms = oComponent.CurrentController.Model.DrawPage.Forms + If oForms.Count < 1 Then Goto Error_MainForm + ReDim vDbContainers(0 To oForms.Count - 1) + For i = 0 To oForms.Count - 1 + vDbContainer = New DbContainer ' To make distinct entries !! + sFormName = oForms.ElementNames(i) + Set vDbContainer.Database = New Database + Set vDbContainer.Database._This = vDbContainer.Database + With vDbContainer.Database + .FormName = sFormName + vDbContainer.FormName = sFormName + Set .Form = oForms.getByName(sFormName) + Set .Connection = .Form.ActiveConnection ' Might be Nothing in Windows at AOO/LO startup (not met in Linux) + If Not IsNull(.Connection) Then + Set .MetaData = .Connection.MetaData + ._LoadMetadata() + ._ReadOnly = .Connection.isReadOnly() + TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False) + End If + Set .Document = oComponent + .Title = oComponent.Title + .URL = .Form.DataSourceName + ._DbConnect = DBCONNECTFORM + Set vDbContainers(i) = vDbContainer + vDbContainers(i).FormName = sFormName + TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False) + End With + Next i + vDocContainer.DbConnect = DBCONNECTFORM + End Select + + vDocContainer.DbContainers() = vDbContainers() + Set vCurrentDoc(iCurrent) = vDocContainer + + _A2B_.CurrentDoc = vCurrentDoc + Set OpenConnection = vDbContainers(0).Database + + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set _A2B_.CurrentDoc = Array() + GoTo Exit_Function +Error_MainForm: + TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title) + Set _A2B_.CurrentDoc = Array() + GoTo Exit_Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) + Goto Exit_Function +End Function ' OpenConnection V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenDatabase ( _ + ByVal Optional pvDatabaseURL As Variant _ + , ByVal Optional pvUser As Variant _ + , ByVal Optional pvPassword As Variant _ + , ByVal Optional pvReadOnly As Variant _ + ) As Variant + +' Return a database object based on input arguments: +' Call template: +' Call OpenDatabase("... databaseURL ..."[, "", "", True/False]) +' pvDatabaseURL may be the name of a registered database or the URL of the targeted .odb file +' Might be called from any AOO/LibO application, independently from OpenConnection + +Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object +Dim i As Integer, bFound As Boolean +Dim sDatabaseURL As String + + If IsEmpty(_A2B_) Then ' First use of Access2Base in current AOO/LibO session + Call Application._RootInit() + TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) + End If + Set OpenDatabase = Nothing + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OpenDatabase" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function + If pvDatabaseURL = "" Then Call _TraceArguments() + If IsMissing(pvUser) Then pvUser = "" + If IsMissing(pvPassword) Then pvPassword = "" + If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function + If IsMissing(pvReadOnly) Then pvReadOnly = False + If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function + + Set odbDatabase = New Database + Set odbDatabase._This = odbDatabase + odbDatabase._DbConnect = DBCONNECTANY + + Set oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + sDbNames() = oBaseContext.getElementNames() + bFound = False + For i = 0 To UBound(sDbNames()) ' Enumerate registered databases and check non case-sensitive equality + If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then + sDatabaseURL = sDbNames(i) + Set oBaseSource = oBaseContext.getByName(sDatabaseURL) + odbDatabase.Location = oBaseContext.getDatabaseLocation(sDbNames(i)) + bFound = True + Exit For + End If + Next i + If Not bFound Then + sDatabaseURL = ConvertToURL(pvDatabaseURL) + If UCase(Right(sDatabaseURL, 4)) <> ".ODB" Then Goto Trace_Error + If Not FileExists(sDatabaseURL) Then Goto Trace_Error + Set oBaseSource = oBaseContext.getByName(sDatabaseURL) + odbDatabase.Location = sDatabaseURL + End If + + Set odbDatabase.Connection = oBaseSource.getConnection(pvUser, pvPassword) + If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist + Set odbDatabase.MetaData = odbDatabase.Connection.MetaData + odbDatabase._LoadMetadata() + Else + Goto Trace_Error + End If + + odbDatabase.URL = sDatabaseURL + + If pvReadOnly Then + odbDatabase.Connection.isReadOnly = True + odbDatabase._ReadOnly = True + End If + + Set OpenDatabase = odbDatabase + + TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False) + + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) + Goto Exit_Function +End Function ' OpenDatabase V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ProductCode() + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session + ProductCode = "Access2Base " & _A2B_.VersionNumber +End Function ' ProductCode V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' setValue also interprets shortcut strings !! +Dim vItem As Variant, sProperty As String + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setValue") + If VarType(pvObject) = vbString Then + Utils._SetCalledSub("setValue") + Set vItem = getObject(pvObject) + sProperty = Utils._FinalProperty(pvObject) + If sProperty = "" Then sProperty = "Value" + setValue = vItem.setProperty(sProperty, pvValue) + Utils._ResetCalledSub("setValue") + Else + Set vItem = pvObject + setValue = vItem.setProperty("Value", pvValue) + End If +End Function ' setValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SysCmd(Optional pvAction As Variant _ + , Optional pvText As Variant _ + , Optional pvValue As Variant _ + ) As Variant +' Manage progress meter in the status bar +' Other values supported by MSAccess are ignored + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SysCmd" + Utils._SetCalledSub(cstThisSub) + SysCmd = False + +Const cstMissing = -1 +Const cstBarLength = 350 + If IsMissing(pvAction) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _ + acSysCmdAccessDir _ + , acSysCmdAccessVer _ + , acSysCmdClearHelpTopic _ + , acSysCmdClearStatus _ + , acSysCmdGetObjectState _ + , acSysCmdGetWorkgroupFile _ + , acSysCmdIniFile _ + , acSysCmdInitMeter _ + , acSysCmdProfile _ + , acSysCmdRemoveMeter _ + , acSysCmdRuntime _ + , acSysCmdSetStatus _ + , acSysCmdUpdateMeter _ + )) Then Goto Exit_Function + If IsMissing(pvValue) Then pvValue = cstMissing + If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function + Select Case pvAction + Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus + If IsMissing(pvText) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvText, 2, vbString) Then Goto Exit_Function + Case Else + End Select + If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function + +Dim vBar As Variant, iLen As Integer + Set vBar = _A2B_.StatusBar + Select Case pvAction + Case acSysCmdAccessVer + SysCmd = Application.Version() + Goto Exit_Function + Case acSysCmdSetStatus + If pvValue <> cstMissing Then Goto Error_Arg + iLen = Len(pvText) + vBar = _NewBar() + If Not IsNull(vBar) Then vBar.start(Iif(iLen >= cstBarLength, pvText, pvText & Space(cstBarLength - iLen)), 0) + Case acSysCmdClearStatus + If pvValue <> cstMissing Then Goto Error_Arg + If Not IsNull(vBar) Then + vBar.end() + Set _A2B_.StatusBar = Nothing + End If + Case acSysCmdInitMeter + If pvValue = cstMissing Then Call _TraceArguments() + vBar = _NewBar() + If Not IsNull(vBar) Then vBar.start(pvText, pvValue) + Case acSysCmdUpdateMeter + If pvValue = cstMissing Then Call _TraceArguments() + If Not IsNull(vBar) Then ' Otherwise ignore ! + vBar.setValue(pvValue) + If Len(pvText) > 0 Then vBar.setText(pvText) + End If + Case acSysCmdRemoveMeter + If Not IsNull(vBar) Then + vBar.end() + Set _A2B_.StatusBar = Nothing + End If + Case acSysCmdRuntime + SysCmd = False + Goto Exit_Function + Case Else + End Select + + SysCmd = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_Arg: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(3, pvValue)) + Goto Exit_Function +End Function ' SysCmd V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TempVars(ByVal Optional pvIndex As Variant) As Variant +' Return either a Collection or a TempVar object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "TempVars" + Utils._SetCalledSub(cstThisSub) + +Dim iMode As Integer, vTempVars As Variant, bFound As Boolean +Const cstCount = 0 +Const cstByIndex = 1 +Const cstByName = 2 + + If IsMissing(pvIndex) Then + iMode = cstCount + Else + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex + End If + + Set vTempVars = Nothing + Select Case iMode + Case cstCount ' Build Collection object + Set vTempVars = New Collect + With vTempVars + ._This = vTempVars + ._CollType = COLLTEMPVARS + ._Count = _A2B_.TempVars.Count + End With + Case cstByIndex ' Build TempVar object + If pvIndex < 0 Or pvIndex >= _A2B_.TempVars.Count Then Goto Trace_Error_Index + Set vTempVars = _A2B_.TempVars.Item(pvIndex + 1) ' Builtin collections start at 1 + Case cstByName + bFound = _A2B_.hasItem(COLLTEMPVARS, pvIndex) + If Not bFound Then Goto Trace_NotFound + vTempVars = _A2B_.TempVars.Item(UCase(pvIndex)) + End Select + + Set TempVars = vTempVars + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vTempVars = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TEMPVAR"), pvIndex)) + Goto Exit_Function +End Function ' TempVars V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Version() As String + Version = Utils._GetProductName() +End Function ' Version V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _CollectNames(ByRef poCollection As Object, ByVal psPrefix As String) As Variant +' Return a "\;" separated list of hierarchical (prefixed with Prefix) and persistent names contained in Collection +' If one of those names refers to a folder, function is called recursively +' Result = 2 items array: (0) list of hierarchical names +' (1) list of persistent names +' +Dim oObject As Object, vNamesList() As Variant, vPersistentList As Variant, i As Integer, sCollect(0 To 1) As String +Dim sName As String, sType As String, sPrefix As String +Const cstFormType = "application/vnd.oasis.opendocument.text" +Const cstSeparator = "\;" + + _CollectNames = sCollect() + vPersistentList = Array() + + With poCollection + If .getCount = 0 Then Exit Function + vNamesList = .getElementNames() + ReDim vPersistentList(0 To UBound(vNamesList)) + + For i = 0 To UBound(vNamesList) + sName = vNamesList(i) + Set oObject = .getByName(sName) + sType = oObject.getContentType() + Select Case sType + Case cstFormType + vNamesList(i) = psPrefix & vNamesList(i) + vPersistentList(i) = oObject.PersistentName + Case "" ' Folder + sCollect = _CollectNames(oObject, psPrefix & sName & "/") + vNamesList(i) = sCollect(0) + vPersistentList(i) = sCollect(1) + Case Else + End Select + Next i + + End With + + Set oObject = Nothing + sCollect(0) = Join(vNamesList, cstSeparator) + sCollect(1) = Join(vPersistentList, cstSeparator) + _CollectNames = sCollect() + +End Function ' _CollectNames V6.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CountOpenForms(ByVal Optional piCountMax As Integer) As Variant +' Return # of active forms if no argument +' Return name of piCountMax-th open form if argument present + +Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant + iAllCount = AllForms._Count + iCount = 0 + If iAllCount > 0 Then + For i = 0 To iAllCount - 1 + Set ofForm = Application.AllForms(i) + If ofForm._IsLoaded Then iCount = iCount + 1 + If Not IsMissing(piCountMax) Then + If iCount = piCountMax + 1 Then + _CountOpenForms = ofForm ' OO3.2 aborts when Set verb present ?!? + Exit For + End If + End If + Next i + End If + + If IsMissing(piCountMax) Then _CountOpenForms = iCount + +End Function ' CountOpenForms V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant +REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use) +REM With 2 arguments return the corresponding entry in Root + +Dim oCurrentDb As Object + If IsEmpty(_A2B_) Then GoTo Trace_Error + If IsMissing(piDocEntry) Then Set oCurrentDb = Application.CurrentDb() _ + Else Set oCurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry) + If IsNull(oCurrentDb) Then Goto Trace_Error Else Set _CurrentDb = oCurrentDb + +Exit_Function: + Exit Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) + Goto Exit_Function +End Function ' _CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetAllHierarchicalNames() As Variant +' Return the full hierarchical names list of a database document +' Get it from the vFormNamesList buffer if the latter is not empty + +Dim vNamesList As Variant, iCurrentDoc As Integer, vCurrentDoc As Variant +Dim oForms As Object +Const cstSeparator = "\;" + + _GetAllHierarchicalNames = Array() + +' Load complete list of names when Base document + iCurrentDoc = _A2B_.CurrentDocIndex() + If iCurrentDoc >= 0 Then vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc) Else Exit Function + If vCurrentDoc.DbConnect = DBCONNECTBASE Then + If IsEmpty(vFormNamesList) Then + Set oForms = vCurrentDoc.Document.getFormDocuments() + vFormNamesList = _CollectNames(oForms, "") + End If + vNamesList = Split(vFormNamesList(0), cstSeparator) + Else + Exit Function + End If + + _GetAllHierarchicalNames = vNamesList + Set oForms = Nothing + +End Function ' _GetAllHierarchicalNames V 6.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetHierarchicalName(ByVal psPersistent As String) As String +' Return the full hierarchical name from the persistent name of a form/report + +Dim vPersistentList As Variant, vNamesList As Variant, i As Integer +Const cstSeparator = "\;" + + _GetHierarchicalName = "" + +' Load complete list of names when Base document + vNamesList = _GetAllHierarchicalNames() + If UBound(vNamesList) < 0 Then Exit Function + vPersistentList = Split(vFormNamesList(1), cstSeparator) + +' Search in list + For i = 0 To UBound(vPersistentList) + If vPersistentList(i) = psPersistent Then + _GetHierarchicalName = vNamesList(i) + Exit For + End If + Next i + +End Function ' _GetHierarchicalName V 6.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _NewBar() As Object +' Close current status bar, if any, and initialize new one + +Dim vBar As Variant, vWindow As Variant, vController As Object + On Local Error Resume Next + Set _NewBar = Nothing + + Set vBar = _A2B_.StatusBar + If Not IsNull(vBar) Then + If Utils._hasUNOMethod(vBar, "end") Then vBar.end() + Set _A2B_.StatusBar = Nothing + End If + + Set vBar = Nothing + Set vWindow = _SelectWindow() + If IsNull(vWindow.Frame) Then Exit Function + Select Case vWindow.WindowType + Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow + Case Else + Exit Function + End Select + If Utils._hasUNOMethod(vWindow.Frame, "getCurrentController") Then + Set vController = vWindow.Frame.getCurrentController() + ElseIf Utils._hasUNOMethod(vWindow.Frame, "getController") Then + Set vController = vWindow.Frame.getController() + End If + + If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator() + Set _A2B_.StatusBar = vBar + Set _NewBar = vBar + Exit Function + +End Function ' _NewBar V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _NewCommandBar(psModule As String _ + , psToolbarName As String _ + , psToolbarFullName As String _ + , piBuiltin As Integer _ + ) As Object + +Dim oObject As Object + Set oObject = New CommandBar + With oObject + ._This = oObject + ._Type = OBJCOMMANDBAR + ._Name = psToolbarName + ._ResourceURL = psToolbarFullName + ._Module = psModule + ._BarBuiltin = piBuiltin + Select Case UCase(Split(psToolbarFullName, "/")(1)) + Case "MENUBAR" : ._BarType = msoBarTypeMenuBar + Case "STATUSBAR" : ._BarType = msoBarTypeStatusBar + Case "TOOLBAR" : ._BarType = msoBarTypeNormal + Case "POPUP" : ._BarType = msoBarTypePopup + Case "FLOATER" : ._BarType = msoBarTypeFloater + Case Else : ._BarType = -1 + End Select + End With + Set _NewCommandBar = oObject + Exit Function + +End Function ' NewCommandBar V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _RootInit(Optional ByVal pbForce As Boolean) +' Initialize _A2B_ global variable. Reinit forced if pbForce = True + + If IsMissing(pbForce) Then pbForce = False + If IsEmpty(_A2B_) Or pbForce Then _A2B_ = New Root_ + +End Sub ' _RootInit V1.1.0 + + \ No newline at end of file diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba new file mode 100644 index 000000000..df964b058 --- /dev/null +++ b/wizards/source/access2base/Collect.xba @@ -0,0 +1,399 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM MODULE NAME <> COLLECTION (is a reserved name for ... collections) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be COLLECTION +Private _This As Object ' Workaround for absence of This builtin function +Private _CollType As String +Private _Parent As Object +Private _Count As Long + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCOLLECTION + Set _This = Nothing + _CollType = "" + Set _Parent = Nothing + _Count = 0 +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get Count() As Long + Count = _PropertyGet("Count") +End Property ' Count (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Function Item(ByVal Optional pvItem As Variant) As Variant +'Return property value. +'pvItem either numeric index or property name + +Const cstThisSub = "Collection.getItem" + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvItem) Then Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error + Select Case _CollType + Case COLLCOMMANDBARCONTROLS ' Have no name + If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric()) Then Goto Exit_Function + Case Else + If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End Select + +Dim vNames() As Variant, oProperty As Object + + Set Item = Nothing + Select Case _CollType + Case COLLALLDIALOGS + Set Item = Application.AllDialogs(pvItem) + Case COLLALLFORMS + Set Item = Application.AllForms(pvItem) + Case COLLALLMODULES + Set Item = Application.AllModules(pvItem) + Case COLLCOMMANDBARS + Set Item = Application.CommandBars(pvItem) + Case COLLCOMMANDBARCONTROLS + If IsNull(_Parent) Then GoTo Error_Parent + Set Item = _Parent.CommandBarControls(pvItem) + Case COLLCONTROLS + If IsNull(_Parent) Then GoTo Error_Parent + Set Item = _Parent.Controls(pvItem) + Case COLLFORMS + Set Item = Application.Forms(pvItem) + Case COLLFIELDS + If IsNull(_Parent) Then GoTo Error_Parent + Set Item = _Parent.Fields(pvItem) + Case COLLPROPERTIES + If IsNull(_Parent) Then GoTo Error_Parent + Select Case _Parent._Type + Case OBJCONTROL, OBJSUBFORM, OBJDATABASE, OBJDIALOG, OBJFIELD _ + , OBJFORM, OBJQUERYDEF, OBJRECORDSET, OBJTABLEDEF + Set Item = _Parent.Properties(pvItem) + Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY + ' NOT SUPPORTED + End Select + Case COLLQUERYDEFS + Set Item = _Parent.QueryDefs(pvItem) + Case COLLRECORDSETS + Set Item = _Parent.Recordsets(pvItem) + Case COLLTABLEDEFS + Set Item = _Parent.TableDefs(pvItem) + Case COLLTEMPVARS + Set Item = Application.TempVars(pvItem) + Case Else + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + Set Item = Nothing + GoTo Exit_Function +Error_Parent: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, True, Array(_GetLabel("OBJECT"), _GetLabel("PARENT"))) + Set Item = Nothing + GoTo Exit_Function +End Function ' Item V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean +' Append a new TableDef or TempVar object to the TableDefs/TempVars collections + +Const cstThisSub = "Collection.Add" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object +Dim vObject As Variant, oTempVar As Object + Add = False + If IsMissing(pvNew) Then Call _TraceArguments() + + Select Case _CollType + Case COLLTABLEDEFS + If Not Utils._CheckArgument(pvNew, 1, vbObject) Then Goto Exit_Function + Set vObject = pvNew + With vObject + Set odbDatabase = ._ParentDatabase + If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Set oConnection = odbDatabase.Connection + If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence + Set oTables = oConnection.getTables() + oTables.appendByDescriptor(.TableDescriptor) + Set .Table = oTables.getByName(._Name) + .CatalogName = .Table.CatalogName + .SchemaName = .Table.SchemaName + .TableName = .Table.Name + .TableDescriptor.dispose() + Set .TableDescriptor = Nothing + .TableFieldsCount = 0 + .TableKeysCount = 0 + End With + Case COLLTEMPVARS + If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function + If pvNew = "" Then Goto Error_Name + If IsMissing(pvValue) Then Call _TraceArguments() + If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name + Set oTempVar = New TempVar + oTempVar._This = oTempVar + oTempVar._Name = pvNew + oTempVar._Value = pvValue + _A2B_.TempVars.Add(oTempVar, UCase(pvNew)) + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count + 1 + Add = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, vObject._Name) + Goto Exit_Function +Error_Name: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew)) + AddItem = False + Goto Exit_Function +End Function ' Add V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Delete(ByVal Optional pvName As Variant) As Boolean +' Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections + +Const cstThisSub = "Collection.Delete" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim odbDatabase As Object, oColl As Object, vName As Variant + Delete = False + If IsMissing(pvName) Then pvName = "" + If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function + If pvName = "" Then Call _TraceArguments() + + Select Case _CollType + Case COLLTABLEDEFS, COLLQUERYDEFS + If _A2B_.CurrentDocIndex() <> 0 Then Goto Error_NotApplicable + Set odbDatabase = Application._CurrentDb() + If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries() + With oColl + vName = _InList(pvName, .getElementNames(), True) + If vName = False Then Goto trace_NotFound + .dropByName(vName) + End With + odbDatabase.Document.store() + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count - 1 + Delete = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName)) + Goto Exit_Function +End Function ' Delete V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Collection.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Collection.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Remove(ByVal Optional pvName As Variant) As Boolean +' Remove a TempVar from the TempVars collection + +Const cstThisSub = "Collection.Remove" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim oColl As Object, vName As Variant + Remove = False + If IsMissing(pvName) Then pvName = "" + If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function + If pvName = "" Then Call _TraceArguments() + + Select Case _CollType + Case COLLTEMPVARS + If Not _A2B_.hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name + _A2B_.TempVars.Remove(UCase(pvName)) + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count - 1 + Remove = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Name: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName)) + AddItem = False + Goto Exit_Function +End Function ' Remove V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveAll() As Boolean +' Remove the whole TempVars collection + +Const cstThisSub = "Collection.Remove" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + + Select Case _CollType + Case COLLTEMPVARS + Set _A2B_.TempVars = New Collection + _Count = 0 + Case Else + Goto Error_NotApplicable + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' RemoveAll V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Count", "Item", "ObjectType") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Collection.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Count") + _PropertyGet = _Count + Case UCase("Item") + Case UCase("ObjectType") + _PropertyGet = _Type + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Collection.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Collection._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + + \ No newline at end of file diff --git a/wizards/source/access2base/CommandBar.xba b/wizards/source/access2base/CommandBar.xba new file mode 100644 index 000000000..c30f696fb --- /dev/null +++ b/wizards/source/access2base/CommandBar.xba @@ -0,0 +1,396 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be COMMANDBAR +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _ResourceURL As String +Private _Window As Object ' com.sun.star.frame.XFrame +Private _Module As String +Private _Toolbar As Object +Private _BarBuiltin As Integer ' 1 = builtin, 2 = custom stored in LO/AOO (Base), 3 = custom stored in document (Form) +Private _BarType As Integer ' See msoBarTypeXxx constants + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCOMMANDBAR + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _ResourceURL = "" + Set _Window = Nothing + _Module = "" + Set _Toolbar = Nothing + _BarBuiltin = 0 + _BarType = -1 +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BuiltIn() As Boolean + BuiltIn = _PropertyGet("BuiltIn") +End Property ' BuiltIn (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _Parent +End Function ' Parent (get) V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CommandBarControls(Optional ByVal pvIndex As Variant) As Variant +' Return an object of type CommandBarControl indicated by its index +' Index is different from UNO index: separators do not count +' If no pvIndex argument, return a Collection type + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBar.CommandBarControls" + Utils._SetCalledSub(cstThisSub) + +Dim oLayout As Object, vElements() As Variant, iIndexToolbar As Integer, oToolbar As Object +Dim i As Integer, iItemsCount As Integer, oSettings As Object, vItem() As Variant, bSeparator As Boolean +Dim oObject As Object + + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < 0 Then Goto Trace_IndexError + End If + + Select Case _BarType + Case msoBarTypeNormal, msoBarTypeMenuBar + Case Else : Goto Error_NotApplicable ' Status bar not supported + End Select + + Set oLayout = _Window.LayoutManager + vElements = oLayout.getElements() + iIndexToolbar = _FindElement(vElements()) + If iIndexToolbar < 0 Then Goto Error_NotApplicable ' Toolbar not visible + Set oToolbar = vElements(iIndexToolbar) + + iItemsCount = 0 + Set oSettings = oToolbar.getSettings(False) + + bSeparator = False + For i = 0 To oSettings.getCount() - 1 + Set vItem() = oSettings.getByIndex(i) + If _GetPropertyValue(vItem, "Type", 1) <> 1 Then ' Type = 1 indicates separator + iItemsCount = iItemsCount + 1 + If Not IsMissing(pvIndex) Then + If pvIndex = iItemsCount - 1 Then + Set oObject = New CommandBarControl + With oObject + Set ._This = oObject + Set ._Parent = _This + ._ParentCommandBarName = _Name + ._ParentCommandBar = oToolbar + ._ParentBuiltin = ( _BarBuiltin = 1 ) + ._Element = vItem() + ._InternalIndex = i + ._Index = iItemsCount ' Indexes start at 1 + ._BeginGroup = bSeparator + End With + End If + bSeparator = False + End If + Else + bSeparator = True + End If + Next i + + If IsNull(oObject) Then + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLCOMMANDBARCONTROLS + Set oObject._Parent = _This + oObject._Count = iItemsCount + Case Else ' pvIndex is numeric + Goto Trace_IndexError + End Select + End If + +Exit_Function: + Set CommandBarControls = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' CommandBarControls V1,3,0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Alias for CommandBarControls (VBA) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBar.Controls" + Utils._SetCalledSub(cstThisSub) + +Dim oObject As Object + + If IsMissing(pvIndex) Then Set oObject = CommandBarControls() Else Set oObject = CommandBarControls(pvIndex) + +Exit_Function: + Set Controls = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Controls V1,3,0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("CommandBar.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("CommandBar.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Reset() As Boolean +' Reset a whole command bar to its initial values + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBar.Reset" + Utils._SetCalledSub(cstThisSub) + + _Toolbar.reload() + +Exit_Function: + Reset = True + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Reset = False + GoTo Exit_Function +End Function ' Reset V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _FindElement(pvElements As Variant) As Integer +' Return -1 if not found, otherwise return index in elements table of LayoutManager + +Dim i As Integer + + _FindElement = -1 + If Not IsArray(pvElements) Then Exit Function + + For i = 0 To UBound(pvElements) + If _ResourceURL = pvElements(i).ResourceURL Then + _FindElement = i + Exit Function + End If + Next i + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("BuiltIn", "Name", "ObjectType", "Visible") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBar.get" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertyGet = Nothing + +Dim oLayout As Object, iElementIndex As Integer + + Select Case UCase(psProperty) + Case UCase("BuiltIn") + _PropertyGet = ( _BarBuiltin = 1 ) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Visible") + Set oLayout = _Window.LayoutManager + iElementIndex = _FindElement(oLayout.getElements()) + If iElementIndex < 0 Then _PropertyGet = False Else _PropertyGet = oLayout.isElementVisible(_ResourceURL) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBar.set" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertySet = True +Dim iArgNr As Integer +Dim oLayout As Object, iElementIndex As Integer + + + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("CommandBar.setProperty") : iArgNr = 2 + Case UCase(cstThisSub) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + Set oLayout = _Window.LayoutManager + With oLayout + iElementIndex = _FindElement(.getElements()) + If iElementIndex < 0 Then + If pvValue Then + .createElement(_ResourceURL) + .showElement(_ResourceURL) + End If + Else + If pvValue <> .isElementVisible(_ResourceURL) Then + If pvValue Then .showElement(_ResourceURL) Else .hideElement(_ResourceURL) + End If + End If + End With + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/CommandBarControl.xba b/wizards/source/access2base/CommandBarControl.xba new file mode 100644 index 000000000..9cf183ba9 --- /dev/null +++ b/wizards/source/access2base/CommandBarControl.xba @@ -0,0 +1,339 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be COMMANDBARCONTROL +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _InternalIndex As Integer ' Index in toolbar including separators +Private _Index As Integer ' Index in collection, starting at 1 !! +Private _ControlType As Integer ' 1 of the msoControl* constants +Private _ParentCommandBarName As String +Private _ParentCommandBar As Object ' com.sun.star.ui.XUIElement +Private _ParentBuiltin As Boolean +Private _Element As Variant +Private _BeginGroup As Boolean + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCOMMANDBARCONTROL + Set _This = Nothing + Set _Parent = Nothing + _Index = -1 + _ParentCommandBarName = "" + Set _ParentCommandBar = Nothing + _ParentBuiltin = False + _Element = Array() + _BeginGroup = False +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BeginGroup() As Boolean + BeginGroup = _PropertyGet("BeginGroup") +End Property ' BeginGroup (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BuiltIn() As Boolean + BuiltIn = _PropertyGet("BuiltIn") +End Property ' BuiltIn (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Index() As Integer + Index = _PropertyGet("Index") +End Property ' Index (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnAction() As Variant + OnAction = _PropertyGet("OnAction") +End Property ' OnAction (get) + +Property Let OnAction(ByVal pvValue As Variant) + Call _PropertySet("OnAction", pvValue) +End Property ' OnAction (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Parent() As Object + Parent = _PropertyGet("Parent") +End Property ' Parent (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TooltipText() As Variant + TooltipText = _PropertyGet("TooltipText") +End Property ' TooltipText (get) + +Property Let TooltipText(ByVal pvValue As Variant) + Call _PropertySet("TooltipText", pvValue) +End Property ' TooltipText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function pType() As Integer + pType = _PropertyGet("Type") +End Function ' Type (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Execute() +' Execute the command stored in a toolbar button + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CommandBarControl.Execute" + Utils._SetCalledSub(cstThisSub) + +Dim sExecute As String + + Execute = True + sExecute = _GetPropertyValue(_Element, "CommandURL", "") + + Select Case True + Case sExecute = "" : Execute = False + Case _IsLeft(sExecute, ".uno:") + Execute = DoCmd.RunCommand(sExecute) + Case _IsLeft(sExecute, "vnd.sun.star.script:") + Execute = Utils._RunScript(sExecute, Array(Nothing)) + Case Else + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Execute = False + GoTo Exit_Function +End Function ' Execute V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("CommandBarControl.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("CommandBar.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("BeginGroup", "BuiltIn", "Caption", "Index" _ + , "ObjectType", "OnAction", "Parent" _ + , "TooltipText", "Type", "Visible" _ + ) +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBarControl.get" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertyGet = Null + +Dim oLayout As Object, iElementIndex As Integer +Dim sValue As String +Const cstUnoPrefix = ".uno:" + + Select Case UCase(psProperty) + Case UCase("BeginGroup") + _PropertyGet = _BeginGroup + Case UCase("BuiltIn") + sValue = _GetPropertyValue(_Element, "CommandURL", "") + _PropertyGet = ( _IsLeft(sValue, cstUnoPrefix) ) + Case UCase("Caption") + _PropertyGet = _GetPropertyValue(_Element, "Label", "") + Case UCase("Index") + _PropertyGet = _Index + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnAction") + _PropertyGet = _GetPropertyValue(_Element, "CommandURL", "") + Case UCase("Parent") + Set _PropertyGet = _Parent + Case UCase("TooltipText") + sValue = _GetPropertyValue(_Element, "Tooltip", "") + If sValue <> "" Then _PropertyGet = sValue Else _PropertyGet = _GetPropertyValue(_Element, "Label", "") + Case UCase("Type") + _PropertyGet = msoControlButton + Case UCase("Visible") + _PropertyGet = _GetPropertyValue(_Element, "IsVisible", "") + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "CommandBarControl.set" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertySet = True +Dim iArgNr As Integer +Dim oSettings As Object, sValue As String + + + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("CommandBar.setProperty") : iArgNr = 2 + Case UCase(cstThisSub) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + If _ParentBuiltin Then Goto Trace_Error ' Modifications of individual controls forbidden for builtin toolbars (design choice) + +Const cstUnoPrefix = ".uno:" +Const cstScript = "vnd.sun.star.script:" + + Set oSettings = _ParentCommandBar.getSettings(True) + Select Case UCase(psProperty) + Case UCase("OnAction") + If Not Utils._CheckArgument(pvValue, iArgNr, _AddNumeric(vbString), , False) Then Goto Trace_Error_Value + Select Case VarType(pvValue) + Case vbString + If _IsLeft(pvValue, cstUnoPrefix) Then + sValue = pvValue + ElseIf _IsLeft(pvValue, cstScript) Then + sValue = pvValue + Else + sValue = DoCmd.RunCommand(pvValue, True) + End If + Case Else ' Numeric + sValue = DoCmd.RunCommand(pvValue, True) + End Select + _SetPropertyValue(_Element, "CommandURL", sValue) + Case UCase("TooltipText") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + _SetPropertyValue(_Element, "Tooltip", pvValue) + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + _SetPropertyValue(_Element, "IsVisible", pvValue) + Case Else + Goto Trace_Error + End Select + oSettings.replaceByIndex(_InternalIndex, _Element) + _ParentCommandBar.setSettings(oSettings) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba new file mode 100644 index 000000000..b22bb819b --- /dev/null +++ b/wizards/source/access2base/Control.xba @@ -0,0 +1,2501 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be CONTROL +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _ImplementationName As String +Private _ClassId As Integer +Private _ParentType As String ' One of CTLPARENTISxxxx constants +Private _Shortcut As String +Private _Name As String +Private _FormComponent As Object ' com.sun.star.text.TextDocument +Private _MainForm As String ' To be propagated to all subcontrols +Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure +Private _DbEntry As Integer +Private _ControlType As Integer +Private _ThisProperties As Variant ' Buffer for properties list +Private _SubType As String +Private ControlModel As Object ' com.sun.star.comp.forms.XXXModel +Private ControlView As Object ' com.sun.star.comp.forms.XXXControl (NULL if form open in edit mode) +Private BoundField As Object ' com.sun.star.sdb.ODataColumn +Private LabelControl As Object ' com.sun.star.form.component.FixedText or com.sun.star.form.component.GroupBox + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJCONTROL + Set _This = Nothing + Set _Parent = Nothing + _ClassId = -1 + _ParentType = "" + _Shortcut = "" + _Name = "" + Set _FormComponent = Nothing + _MainForm = "" + _DocEntry = -1 + _DbEntry = -1 + _ThisProperties = Array() + _SubType = "" + Set ControlModel = Nothing + Set ControlView = Nothing + Set BoundField = Nothing + Set LabelControl = Nothing + +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get BackColor() As Variant + BackColor = _PropertyGet("BackColor") +End Property ' BackColor (get) + +Property Let BackColor(ByVal pvValue As Variant) + Call _PropertySet("BackColor", pvValue) +End Property ' BackColor (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BorderColor() As Variant + BorderColor = _PropertyGet("BorderColor") +End Property ' BorderColor (get) + +Property Let BorderColor(ByVal pvValue As Variant) + Call _PropertySet("BorderColor", pvValue) +End Property ' BorderColor (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BorderStyle() As Variant + BorderStyle = _PropertyGet("BorderStyle") +End Property ' BorderStyle (get) + +Property Let BorderStyle(ByVal pvValue As Variant) + Call _PropertySet("BorderStyle", pvValue) +End Property ' BorderStyle (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Cancel() As Variant + Cancel = _PropertyGet("Cancel") +End Property ' Cancel (get) + +Property Let Cancel(ByVal pvValue As Variant) + Call _PropertySet("Cancel", pvValue) +End Property ' Cancel (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ControlSource() As Variant + ControlSource = _PropertyGet("ControlSource") +End Property ' ControlSource (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ControlTipText() As Variant + ControlTipText = _PropertyGet("ControlTipText") +End Property ' ControlTipText (get) + +Property Let ControlTipText(ByVal pvValue As Variant) + Call _PropertySet("ControlTipText", pvValue) +End Property ' ControlTipText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ControlType() As Variant + ControlType = _PropertyGet("ControlType") +End Property ' ControlType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Default() As Variant + Default = _PropertyGet("Default") +End Property ' Default (get) + +Property Let Default(ByVal pvValue As Variant) + Call _PropertySet("Default", pvValue) +End Property ' Default (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get DefaultValue() As Variant + DefaultValue = _PropertyGet("DefaultValue") +End Property ' DefaultValue (get) + +Property Let DefaultValue(ByVal pvValue As Variant) + Call _PropertySet("DefaultValue", pvValue) +End Property ' DefaultValue (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Enabled() As Variant + Enabled = _PropertyGet("Enabled") +End Property ' Enabled (get) + +Property Let Enabled(ByVal pvValue As Variant) + Call _PropertySet("Enabled", pvValue) +End Property ' Enabled (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontBold() As Variant + FontBold = _PropertyGet("FontBold") +End Property ' FontBold (get) + +Property Let FontBold(ByVal pvValue As Variant) + Call _PropertySet("FontBold", pvValue) +End Property ' FontBold (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontItalic() As Variant + FontItalic = _PropertyGet("FontItalic") +End Property ' FontItalic (get) + +Property Let FontItalic(ByVal pvValue As Variant) + Call _PropertySet("FontItalic", pvValue) +End Property ' FontItalic (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontName() As Variant + FontName = _PropertyGet("FontName") +End Property ' FontName (get) + +Property Let FontName(ByVal pvValue As Variant) + Call _PropertySet("FontName", pvValue) +End Property ' FontName (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontSize() As Variant + FontSize = _PropertyGet("FontSize") +End Property ' FontSize (get) + +Property Let FontSize(ByVal pvValue As Variant) + Call _PropertySet("FontSize", pvValue) +End Property ' FontSize (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontUnderline() As Variant + FontUnderline = _PropertyGet("FontUnderline") +End Property ' FontUnderline (get) + +Property Let FontUnderline(ByVal pvValue As Variant) + Call _PropertySet("FontUnderline", pvValue) +End Property ' FontUnderline (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FontWeight() As Variant + FontWeight = _PropertyGet("FontWeight") +End Property ' FontWeight (get) + +Property Let FontWeight(ByVal pvValue As Variant) + Call _PropertySet("FontWeight", pvValue) +End Property ' FontWeight (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ForeColor() As Variant + ForeColor = _PropertyGet("ForeColor") +End Property ' ForeColor (get) + +Property Let ForeColor(ByVal pvValue As Variant) + Call _PropertySet("ForeColor", pvValue) +End Property ' ForeColor (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Form() As Variant + Form = _PropertyGet("Form") +End Property ' Form (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Format() As Variant + Format = _PropertyGet("Format") +End Property ' Format (get) + +Property Let Format(ByVal pvValue As Variant) + Call _PropertySet("Format", pvValue) +End Property ' Format (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ItemData(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then ItemData = _PropertyGet("ItemData") Else ItemData = _PropertyGet("ItemData", pvIndex) +End Property ' ItemData (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ListCount() As Variant + ListCount = _PropertyGet("ListCount") +End Property ' ListCount (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ListIndex() As Variant + ListIndex = _PropertyGet("ListIndex") +End Property ' ListIndex (get) + +Property Let ListIndex(ByVal pvValue As Variant) + Call _PropertySet("ListIndex", pvValue) +End Property ' ListIndex (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Locked() As Variant + Locked = _PropertyGet("Locked") +End Property ' Locked (get) + +Property Let Locked(ByVal pvValue As Variant) + Call _PropertySet("Locked", pvValue) +End Property ' Locked (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get MultiSelect() As Variant + MultiSelect = _PropertyGet("MultiSelect") +End Property ' MultiSelect (get) + +Property Let MultiSelect(ByVal pvValue As Variant) + Call _PropertySet("MultiSelect", pvValue) +End Property ' MultiSelect (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnActionPerformed() As Variant + OnActionPerformed = _PropertyGet("OnActionPerformed") +End Property ' OnActionPerformed (get) + +Property Let OnActionPerformed(ByVal pvValue As Variant) + Call _PropertySet("OnActionPerformed", pvValue) +End Property ' OnActionPerformed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnAdjustmentValueChanged() As Variant + OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged") +End Property ' OnAdjustmentValueChanged (get) + +Property Let OnAdjustmentValueChanged(ByVal pvValue As Variant) + Call _PropertySet("OnAdjustmentValueChanged", pvValue) +End Property ' OnAdjustmentValueChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveAction() As Variant + OnApproveAction = _PropertyGet("OnApproveAction") +End Property ' OnApproveAction (get) + +Property Let OnApproveAction(ByVal pvValue As Variant) + Call _PropertySet("OnApproveAction", pvValue) +End Property ' OnApproveAction (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' OnApproveReset (get) + +Property Let OnApproveReset(ByVal pvValue As Variant) + Call _PropertySet("OnApproveReset", pvValue) +End Property ' OnApproveReset (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveUpdate() As Variant + OnApproveUpdate = _PropertyGet("OnApproveUpdate") +End Property ' OnApproveUpdate (get) + +Property Let OnApproveUpdate(ByVal pvValue As Variant) + Call _PropertySet("OnApproveUpdate", pvValue) +End Property ' OnApproveUpdate (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnChanged() As Variant + OnChanged = _PropertyGet("OnChanged") +End Property ' OnChanged (get) + +Property Let OnChanged(ByVal pvValue As Variant) + Call _PropertySet("OnChanged", pvValue) +End Property ' OnChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' OnErrorOccurred (get) + +Property Let OnErrorOccurred(ByVal pvValue As Variant) + Call _PropertySet("OnErrorOccurred", pvValue) +End Property ' OnErrorOccurred (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' OnFocusGained (get) + +Property Let OnFocusGained(ByVal pvValue As Variant) + Call _PropertySet("OnFocusGained", pvValue) +End Property ' OnFocusGained (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' OnFocusLost (get) + +Property Let OnFocusLost(ByVal pvValue As Variant) + Call _PropertySet("OnFocusLost", pvValue) +End Property ' OnFocusLost (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnItemStateChanged() As Variant + OnItemStateChanged = _PropertyGet("OnItemStateChanged") +End Property ' OnItemStateChanged (get) + +Property Let OnItemStateChanged(ByVal pvValue As Variant) + Call _PropertySet("OnItemStateChanged", pvValue) +End Property ' OnItemStateChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' OnKeyPressed (get) + +Property Let OnKeyPressed(ByVal pvValue As Variant) + Call _PropertySet("OnKeyPressed", pvValue) +End Property ' OnKeyPressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' OnKeyReleased (get) + +Property Let OnKeyReleased(ByVal pvValue As Variant) + Call _PropertySet("OnKeyReleased", pvValue) +End Property ' OnKeyReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' OnMouseDragged (get) + +Property Let OnMouseDragged(ByVal pvValue As Variant) + Call _PropertySet("OnMouseDragged", pvValue) +End Property ' OnMouseDragged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' OnMouseEntered (get) + +Property Let OnMouseEntered(ByVal pvValue As Variant) + Call _PropertySet("OnMouseEntered", pvValue) +End Property ' OnMouseEntered (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' OnMouseExited (get) + +Property Let OnMouseExited(ByVal pvValue As Variant) + Call _PropertySet("OnMouseExited", pvValue) +End Property ' OnMouseExited (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' OnMouseMoved (get) + +Property Let OnMouseMoved(ByVal pvValue As Variant) + Call _PropertySet("OnMouseMoved", pvValue) +End Property ' OnMouseMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' OnMousePressed (get) + +Property Let OnMousePressed(ByVal pvValue As Variant) + Call _PropertySet("OnMousePressed", pvValue) +End Property ' OnMousePressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' OnMouseReleased (get) + +Property Let OnMouseReleased(ByVal pvValue As Variant) + Call _PropertySet("OnMouseReleased", pvValue) +End Property ' OnMouseReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnResetted() As Variant + OnResetted = _PropertyGet("OnResetted") +End Property ' OnResetted (get) + +Property Let OnResetted(ByVal pvValue As Variant) + Call _PropertySet("OnResetted", pvValue) +End Property ' OnResetted (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnTextChanged() As Variant + OnTextChanged = _PropertyGet("OnTextChanged") +End Property ' OnTextChanged (get) + +Property Let OnTextChanged(ByVal pvValue As Variant) + Call _PropertySet("OnTextChanged", pvValue) +End Property ' OnTextChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUpdated() As Variant + OnUpdated = _PropertyGet("OnUpdated") +End Property ' OnUpdated (get) + +Property Let OnUpdated(ByVal pvValue As Variant) + Call _PropertySet("OnUpdated", pvValue) +End Property ' OnUpdated (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OptionValue() As Variant + OptionValue = _PropertyGet("OptionValue") +End Property ' OptionValue (get) + +Property Let OptionValue(ByVal pvValue As Variant) + Call _PropertySet("OptionValue", pvValue) +End Property ' OptionValue (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Page() As Variant + Page = _PropertyGet("Page") +End Property ' Page (get) + +Property Let Page(ByVal pvValue As Variant) + Call _PropertySet("Page", pvValue) +End Property ' Page (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _PropertyGet("Parent") +End Function ' Parent (get) V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Picture() As Variant + Picture = _PropertyGet("Picture") +End Property ' Picture (get) + +Property Let Picture(ByVal pvValue As Variant) + Call _PropertySet("Picture", pvValue) +End Property ' Picture (set) V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + + Utils._SetCalledSub("Control.Properties") +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub("Control.Properties") + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Required() As Variant + Required = _PropertyGet("Required") +End Property ' Required (get) + +Property Let Required(ByVal pvValue As Variant) + Call _PropertySet("Required", pvValue) +End Property ' Required (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RowSource() As Variant + RowSource = _PropertyGet("RowSource") +End Property ' RowSource (get) + +Property Let RowSource(ByVal pvValue As Variant) + Call _PropertySet("RowSource", pvValue) +End Property ' RowSource (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RowSourceType() As Variant + RowSourceType = _PropertyGet("RowSourceType") +End Property ' RowSourceType (get) + +Property Let RowSourceType(ByVal pvValue As Variant) + Call _PropertySet("RowSourceType", pvValue) +End Property ' RowSourceType (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Selected(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then Selected = _PropertyGet("Selected") Else Selected = _PropertyGet("Selected", pvIndex) +End Property ' Selected (get) + +Property Let Selected(ByVal pvValue As Variant) ' , ByVal Optional pvIndex As Variant) +' If IsMissing(pvIndex) Then Call _PropertySet("Selected", pvValue) Else Call _PropertySet("Selected", pvValue, pvIndex) + Call _PropertySet("Selected", pvValue) +End Property ' Selected (set) + +Public Function SelectedI(ByVal pvValue As variant, ByVal pvIndex As Variant) + Call _PropertySet("Selected", pvValue, pvIndex) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelLength() As Variant + SelLength = _PropertyGet("SelLength") +End Property ' SelLength (get) + +Property Let SelLength(ByVal pvValue As Variant) + Call _PropertySet("SelLength", pvValue) +End Property ' SelLength (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelStart() As Variant + SelStart = _PropertyGet("SelStart") +End Property ' SelStart (get) + +Property Let SelStart(ByVal pvValue As Variant) + Call _PropertySet("SelStart", pvValue) +End Property ' SelStart (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelText() As Variant + SelText = _PropertyGet("SelText") +End Property ' SelText (get) + +Property Let SelText(ByVal pvValue As Variant) + Call _PropertySet("SelText", pvValue) +End Property ' SelText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SpecialEffect() As Variant + SpecialEffect = _PropertyGet("SpecialEffect") +End Property ' SpecialEffect (get) + +Property Let SpecialEffect(ByVal pvValue As Variant) + Call _PropertySet("SpecialEffect", pvValue) +End Property ' SpecialEffect (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SubType() As Variant + SubType = _PropertyGet("SubType") +End Property ' SubType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TabIndex() As Variant + TabIndex = _PropertyGet("TabIndex") +End Property ' TabIndex (get) + +Property Let TabIndex(ByVal pvValue As Variant) + Call _PropertySet("TabIndex", pvValue) +End Property ' TabIndex (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TabStop() As Variant + TabStop = _PropertyGet("TabStop") +End Property ' TabStop (get) + +Property Let TabStop(ByVal pvValue As Variant) + Call _PropertySet("TabStop", pvValue) +End Property ' TabStop (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Tag() As Variant + Tag = _PropertyGet("Tag") +End Property ' Tag (get) + +Property Let Tag(ByVal pvValue As Variant) + Call _PropertySet("Tag", pvValue) +End Property ' Tag (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Text() As Variant + Text = _PropertyGet("Text") +End Property ' Text (get) + +Public Function pText() As Variant + pText = _PropertyGet("Text") +End Function ' pText (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TextAlign() As Variant + TextAlign = _PropertyGet("TextAlign") +End Property ' TextAlign (get) + +Property Let TextAlign(ByVal pvValue As Variant) + Call _PropertySet("TextAlign", pvValue) +End Property ' TextAlign (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TripleState() As Variant + TripleState = _PropertyGet("TripleState") +End Property ' TripleState (get) + +Property Let TripleState(ByVal pvValue As Variant) + Call _PropertySet("TripleState", pvValue) +End Property ' TripleState (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function AddItem(ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean +' Add an item in a Listbox + + Utils._SetCalledSub("Control.AddItem") + AddItem = False + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvIndex) Then pvIndex = -1 + +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("AddItem") : iArgNr = 1 + Case UCase("Control.AddItem") : iArgNr = 0 + End Select + + If Not Utils._CheckArgument(pvItem, iArgNr + 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvIndex, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function + If _SubType <> CTLLISTBOX Then Goto Error_Control + If _ParentType <> CTLPARENTISDIALOG Then + If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control + End If + +Dim vRowSource() As Variant, iCount As Integer, i As Integer + If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList) + iCount = UBound(vRowSource) + If pvIndex < -1 Or pvIndex > iCount + 1 Then Goto Error_Index + ReDim Preserve vRowSource(0 To iCount + 1) + If pvIndex = -1 Then pvIndex = iCount + 1 + For i = iCount + 1 To pvIndex + 1 Step -1 + vRowSource(i) = vRowSource(i - 1) + Next i + vRowSource(pvIndex) = pvItem + + If _ParentType <> CTLPARENTISDIALOG Then + ControlModel.ListSource = vRowSource() + End If + ControlModel.StringItemList = vRowSource() + AddItem = True + +Exit_Function: + Utils._ResetCalledSub("Control.AddItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.AddItem", Erl) + AddItem = False + GoTo Exit_Function +Error_Control: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Control.AddItem") + AddItem = False + Goto Exit_Function +Error_Index: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(iArgNr + 2,pvIndex)) + AddItem = False + Goto Exit_Function +End Function ' AddItem V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +Const cstThisSub = "Control.Controls" +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + +Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer, oView As Object + + If _SubType <> CTLGRIDCONTROL Then Goto Trace_Error_Context + Set ocControl = Nothing + iControlCount = ControlModel.getCount() + + If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + oCounter._Count = iControlCount + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISGRID + sParentShortcut = _Shortcut + sControls() = ControlModel.getElementNames() + + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + ocControl._Name = sControls(pvIndex) + Case vbString ' Check control name validity (non case sensitive) + bFound = False + sIndex = UCase(Utils._Trim(pvIndex)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sIndex Then + bFound = True + Exit For + End If + Next i + If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + End Select + + With ocControl + ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) + Set .ControlModel = ControlModel.getByName(._Name) + ._ImplementationName = .ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? + ._FormComponent = ParentComponent + ._MainForm = _MainForm + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + ' Complex bypass to find View of grid subcontrols ! + If Not IsNull(ControlView) Then ' Anticipate absence of ControlView in grid controls when edit mode + For i = 0 to ControlView.getCount() - 1 + Set oView = ControlView.GetByIndex(i) + If Not IsNull(oView) Then + If oView.getModel.Name = ._Name Then + Set .ControlView = oView + Exit For + End If + End If + Next i + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_Context: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Grid.Controls") + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Control.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + If IsMissing(pvIndex) Then + getProperty = _PropertyGet(pvProperty) + Else + getProperty = _PropertyGet(pvProperty, pvIndex) + End If + Utils._ResetCalledSub("Control.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveItem(ByVal Optional pvIndex) As Boolean +' Remove an item from a Listbox +' Index may be a string value or an index-position + + Utils._SetCalledSub("Control.RemoveItem") + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvIndex) Then Call _TraceArguments() +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("RemoveItem") : iArgNr = 1 + Case UCase("Control.RemoveItem") : iArgNr = 0 + End Select + If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + If _SubType <> CTLLISTBOX Then Goto Error_Control + If _ParentType <> CTLPARENTISDIALOG Then + If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control + End If + +Dim vRowSource() As Variant, iCount As Integer, i As Integer, j As integer, bFound As Boolean + If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList) + iCount = UBound(vRowSource) + + Select Case VarType(pvIndex) + Case vbString + bFound = False + For i = 0 To iCount + If vRowSource(i) = pvIndex Then + For j = i To iCount - 1 + vRowSource(j) = vRowSource(j + 1) + Next j + bFound = True + Exit For ' Remove only 1st occurrence of string + End If + Next i + Case Else + If pvIndex < 0 Or pvIndex > iCount Then Goto Error_Index + For i = pvIndex To iCount - 1 + vRowSource(i) = vRowSource(i + 1) + Next i + bFound = True + End Select + + If bFound Then + If iCount > 0 Then ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=75008 + ReDim Preserve vRowSource(0 To iCount - 1) + Else + vRowSource = Array() + End If + If _ParentType <> CTLPARENTISDIALOG Then + ControlModel.ListSource = vRowSource() + End If + ControlModel.StringItemList = vRowSource() + RemoveItem = True + Else + RemoveItem = False + End If + +Exit_Function: + Utils._ResetCalledSub("Control.RemoveItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.RemoveItem", Erl) + RemoveItem = False + GoTo Exit_Function +Error_Control: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.RemoveItem") + RemoveItem = False + Goto Exit_Function +Error_Index: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(2, pvIndex)) + RemoveItem = False + Goto Exit_Function +End Function ' RemoveItem V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery() As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("Control.Requery") + If _ErrorHandler() Then On Local Error Goto Error_Function + Requery = False + + Select Case _SubType + Case CTLCOMBOBOX, CTLLISTBOX + If Utils._InList(ControlModel.ListSourceType, Array( _ + com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.TABLEFIELDS _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + )) Then + ControlModel.refresh() + End If + Case Else + Goto Error_Control + End Select + Requery = True + +Exit_Function: + Utils._ResetCalledSub("Control.Requery") + Exit Function +Error_Control: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.Requery") + Requery = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.Requery", Erl) + GoTo Exit_Function +End Function ' Requery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetFocus() As Boolean +' Execute setFocus method + Utils._SetCalledSub("Control.SetFocus") + If _ErrorHandler() Then On Local Error Goto Error_Function + SetFocus = False + +Dim i As Integer, j As Integer, iColPosition As Integer +Dim ocControl As Object, ocGrid As Variant, oGridModel As Object + + If IsNull(ControlView) Then GoTo Exit_Function + If _ParentType = CTLPARENTISGRID Then 'setFocus method does not work on controlviews in grid ?!? + ' Find column position of control + iColPosition = -1 + ocGrid = getObject(_getUpperShortcut(_Shortcut, _Name)) ' return containing grid + Set oGridModel = ocGrid.ControlModel + j = -1 + For i = 0 To oGridModel.Count - 1 + Set ocControl = oGridModel.GetByIndex(i) + If Not ocControl.Hidden Then j = j + 1 ' Skip if hidden + If oGridModel.GetByIndex(i).Name = _Name Then + iColPosition = j + Exit For + End If + Next i + If iColPosition >= 0 Then + ocGrid.ControlView.setFocus() 'Set first focus on grid itself + ocGrid.ControlView.setCurrentColumnPosition(iColPosition) 'Deprecated but no alternative found + Else + Goto Error_Grid + End If + Else + ControlView.setFocus() + End If + SetFocus = True + +Exit_Function: + Utils._ResetCalledSub("Control.SetFocus") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Control.SetFocus", Erl) + Goto Exit_Function +Error_Grid: + TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(_Name, ocGrid._Name)) + Goto Exit_Function +End Function ' SetFocus V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("Control.setProperty") + If IsMissing(pvIndex) Then + setProperty = _PropertySet(psProperty, pvValue) + Else + setProperty = _PropertySet(psProperty, pvValue, pvIndex) + End If + Utils._ResetCalledSub("Control.setProperty") +End Function ' setProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetSelected(ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Workaround for limitation of Basic: Property Let does not accept optional arguments + + If IsMissing(pvValue) Then Call _TraceArguments() + If IsMissing(pvIndex) Then + SetSelected = _PropertySet("Selected", pvValue) + Else + SetSelected = _PropertySet("Selected", pvValue, pvIndex) + End If + +End Function ' SetSelected + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _Formats(ByVal psControlType As String) As Variant +' Return allowed format entries for Date and Time control types + +Dim vFormats() As Variant + Select Case psControlType + Case CTLDATEFIELD + vFormats = Array( _ + "Standard (short)" _ + , "Standard (short YY)" _ + , "Standard (short YYYY)" _ + , "Standard (long)" _ + , "DD/MM/YY" _ + , "MM/DD/YY" _ + , "YY/MM/DD" _ + , "DD/MM/YYYY" _ + , "MM/DD/YYYY" _ + , "YYYY/MM/DD" _ + , "YY-MM-DD" _ + , "YYYY-MM-DD" _ + ) + Case CTLTIMEFIELD + vFormats = Array( _ + "24h short" _ + , "24h long" _ + , "12h short" _ + , "12h long" _ + ) + Case Else + vFormats = Array() + End Select + + _Formats = vFormats + +End Function ' _Formats V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnActionPerformed") + _GetListener = "XActionListener" + Case UCase("OnAdjustmentValueChanged") + _GetListener = "XAdjustmentListener" + Case UCase("OnApproveAction") + _GetListener = "XApproveActionListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveUpdate"), UCase("OnUpdated") + _GetListener = "XUpdateListener" + Case UCase("OnChanged") + _GetListener = "XChangeListener" + Case UCase("OnErrorOccurred") + _GetListener = "XErrorListener" + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnItemStateChanged") + _GetListener = "XItemListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case UCase("OnTextChanged") + _GetListener = "XTextListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize() +' Initialize new Control +' ControlModel, ParentType, Name, Shortcut, ControlView, ImplementationName, ClassId (if parent <> dialog) +' are presumed preexisting + + ' Identify SubType and ControlView +Dim sControlTypes() As Variant, i As Integer, vSplit() As Variant, sTrailer As String + sControlTypes = array( CTLCONTROL _ + , CTLCOMMANDBUTTON _ + , CTLRADIOBUTTON _ + , CTLIMAGEBUTTON _ + , CTLCHECKBOX _ + , CTLLISTBOX _ + , CTLCOMBOBOX _ + , CTLGROUPBOX _ + , CTLTEXTFIELD _ + , CTLFIXEDTEXT _ + , CTLGRIDCONTROL _ + , CTLFILECONTROL _ + , CTLHIDDENCONTROL _ + , CTLIMAGECONTROL _ + , CTLDATEFIELD _ + , CTLTIMEFIELD _ + , CTLNUMERICFIELD _ + , CTLCURRENCYFIELD _ + , CTLPATTERNFIELD _ + , CTLSCROLLBAR _ + , CTLSPINBUTTON _ + , CTLNAVIGATIONBAR _ + , CTLPROGRESSBAR _ + , CTLFIXEDLINE _ + ) + + Select Case _ParentType + Case CTLPARENTISDIALOG + vSplit = Split(ControlModel.getServiceName(), ".") + sTrailer = UCase(vSplit(UBound(vSplit))) + ' Manage homonyms + Select Case sTrailer + Case "BUTTON" : sTrailer = CTLCOMMANDBUTTON + Case "EDIT" : sTrailer = CTLTEXTFIELD + Case Else + End Select + If sTrailer <> CTLFORMATTEDFIELD Then + For i = 0 To UBound(sControlTypes) + If sControlTypes(i) = sTrailer Then + _ClassId = i + 1 + _SubType = sTrailer + _ControlType = _ClassId + Exit For + End If + Next i + Else + _ClassId = acFormattedField + _SubType = CTLFORMATTEDFIELD + _ControlType = _ClassId + End If + Case Else + 'Is ClassId one of the properties ? + If _ClassId > 0 Then ' All control types have a ClassId except subforms + _SubType = sControlTypes(_ClassId - 1) + _ControlType = _ClassId + If _SubType = CTLTEXTFIELD Then ' Formatted fields belong to the TextField family + If _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper" _ + Or _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper_ForcedFormatted" _ + Or _ImplementationName = "com.sun.star.form.component.FormattedField" Then ' When in datagrid + _SubType = CTLFORMATTEDFIELD + _ControlType = acFormattedField + End If + End If + Else ' Initialize subform Control + If ControlModel.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then + _SubType = CTLSUBFORM + _ControlType = acSubform + End If + End If + End Select + +End Sub ' _Initialize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ListboxBound() As Boolean +' Return True if listbox has a bound column + +Dim bListboxBound As Boolean, j As Integer +Dim vValue() As variant, vString As Variant + + bListboxBound = False + + If Not IsNull(ControlModel.ValueItemList) _ + And ControlModel.DataField <> "" _ + And Not IsNull(ControlModel.BoundField) _ + And Utils._InList(ControlModel.ListSourceType, Array( _ + com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + )) Then ' MultiSelect behaviour changed in OpenOffice >= 3.3 + If IsArray(ControlModel.ValueItemList) Then + vValue = ControlModel.ValueItemList + vString = ControlModel.StringItemList + For j = 0 To UBound(vValue) + If VarType(vValue(j)) <> VarType(vString(j)) Then + bListboxBound = True + ElseIf vValue(j) <> vString(j) Then + bListboxBound = True + End If + If bListboxBound Then Exit For + Next j + End If + End If + + _ListboxBound = bListboxBound + +End Function ' _ListboxBound V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant +' Based on ControlProperties.ods analysis + +Dim vFullPropertiesList() As Variant + + 'List established only once + If UBound(_ThisProperties) > -1 Then + _PropertiesList = _ThisProperties + Exit Function + End If + + vFullPropertiesList = Array( _ + "BackColor" _ + , "BorderColor" _ + , "BorderStyle" _ + , "Cancel" _ + , "Caption" _ + , "ControlSource" _ + , "ControlTipText" _ + , "ControlType" _ + , "Default" _ + , "DefaultValue" _ + , "Enabled" _ + , "FontBold" _ + , "FontItalic" _ + , "FontName" _ + , "FontSize" _ + , "FontUnderline" _ + , "FontWeight" _ + , "ForeColor" _ + , "Form" _ + , "Format" _ + , "ItemData" _ + , "LinkChildFields" _ + , "LinkMasterFields" _ + , "ListCount" _ + , "ListIndex" _ + , "Locked" _ + , "MultiSelect" _ + , "Name" _ + , "ObjectType" _ + , "OnActionPerformed" _ + , "OnAdjustmentValueChanged" _ + , "OnApproveAction" _ + , "OnApproveReset" _ + , "OnApproveUpdate" _ + , "OnChanged" _ + , "OnErrorOccurred" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnItemStateChanged" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "OnResetted" _ + , "OnTextChanged" _ + , "OnUpdated" _ + , "OptionValue" _ + , "Page" _ + , "Parent" _ + , "Picture" _ + , "Required" _ + , "RowSource" _ + , "RowSourceType" _ + , "Selected" _ + , "SelLength" _ + , "SelStart" _ + , "Seltext" _ + , "SpecialEffect" _ + , "SubType" _ + , "TabIndex" _ + , "TabStop" _ + , "Tag" _ + , "Text" _ + , "TextAlign" _ + , "TripleState" _ + , "Value" _ + , "Visible" _ + ) +Dim vPropertiesMatrix(25) As Variant + Select Case _ParentType + Case CTLPARENTISFORM, CTLPARENTISSUBFORM + vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,63,64,65,67,68,69,70) + vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,41,42,43,44,45,46,47,52,53,62,63,64,65,67,69,70) + vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70) + vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,48,52,62,63,64,65,66,69,70) + vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,65,67,70) + vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,70) + vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,62,65,70) + vPropertiesMatrix(acHiddenControl) = Array(7,27,28,52,62,65,69,70) + vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,36,37,39,40,41,42,43,44,45,46,52,53,62,63,64,65,70) + vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,53,54,62,63,64,65,70) + vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,63,64,65,67,69,70) + vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,63,64,65,70) + vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70) + vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70) + vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70) + vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70) + vPropertiesMatrix(0) = Array(7,18,21,22,27,28,52,62) + vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) + Case CTLPARENTISGROUP + ' To be duplicated from above !!! + vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70) + Case CTLPARENTISGRID + vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,65,67,68,69) + vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,65,66,67,69) + vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69) + vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) + vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) + vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,65,67,69) + vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69) + vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69) + vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69) + vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) + Case CTLPARENTISDIALOG + vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,61,62,63,64,65,67,68,69,70) + vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,36,37,38,39,40,41,42,43,44,45,46,48,51,52,55,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,67,70) + vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70) + vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70) + vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,67,70) + vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70) + vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,70) + vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,55,57,62,63,64,65,67,69,70) + vPropertiesMatrix(acNavigationBar) = Array(36,37,39,40,41,42,43,44,45,46) + vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70) + vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,69,70) + vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,50,51,52,61,62,63,64,65,67,69,70) + vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,69,70) + vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70) + vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) + End Select + +Dim i As Integer, iIndex As Integer + If _ControlType = acSubForm Then iIndex = 0 Else iIndex = _ControlType + If IsEmpty(vPropertiesMatrix(iIndex)) Then + _ThisProperties = Array() + Else + ReDim _ThisProperties(0 To UBound(vPropertiesMatrix(iIndex))) + For i = 0 To UBound(_ThisProperties) + _ThisProperties(i) = vFullPropertiesList(vPropertiesMatrix(iIndex)(i)) + Next i + End If + + _PropertiesList = _ThisProperties() + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant +' Return property value of the psProperty property name + +Dim iArg As Integer + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Control.get" & psProperty) + _PropertyGet = EMPTY + +'Check Index argument +Dim iArgNr As Integer + If Not IsMissing(pvIndex) Then + Select Case UCase(_A2B_.CalledSub) + Case UCase("getProperty") : iArgNr = 3 + Case UCase("Control.getProperty") : iArgNr = 2 + Case UCase("Control.get" & psProperty) : iArgNr = 1 + End Select + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + End If + +Dim vDefaultValue As Variant, oDefaultValue As Object, vValue As Variant, oValue As Object, iIndex As Integer +Dim lListIndex As Long, i As Integer, j As Integer, vCurrentValue As Variant, lListCount As Long +Dim vListboxValue As Variant, vListSource, bSelected() As Boolean, bListboxBound As Boolean +Dim vGet As Variant, vDate As Variant +Dim ofSubForm As Object +Dim vFormats() As Variant +Dim vSelection As Variant, sSelectedText As String +Dim oControlEvents As Object, sEventName As String + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("BackColor") + If Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then _PropertyGet = ControlModel.BackgroundColor + Case UCase("BorderColor") + If Utils._hasUNOProperty(ControlModel, "BorderColor") Then _PropertyGet = ControlModel.BorderColor + Case UCase("BorderStyle") + If Utils._hasUNOProperty(ControlModel, "Border") Then _PropertyGet = ControlModel.Border + Case UCase("Cancel") + If Utils._hasUNOProperty(ControlModel, "PushButtonType") Then _PropertyGet = ( ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL ) + Case UCase("Caption") + If Utils._hasUNOProperty(ControlModel, "Label") Then _PropertyGet = ControlModel.Label + Case UCase("ControlSource") + If Utils._hasUNOProperty(ControlModel, "DataField") Then _PropertyGet = ControlModel.DataField + Case UCase("ControlTipText") + If Utils._hasUNOProperty(ControlModel, "HelpText") Then _PropertyGet = ControlModel.HelpText + Case UCase("ControlType") + _PropertyGet = _ControlType + Case UCase("Default") + If Utils._hasUNOProperty(ControlModel, "DefaultButton") Then _PropertyGet = ControlModel.DefaultButton + Case UCase("DefaultValue") + Select Case _SubType + Case CTLCHECKBOX, CTLRADIOBUTTON + If Utils._hasUNOProperty(ControlModel, "DefaultState") Then _PropertyGet = ControlModel.DefaultState + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultText") Then _PropertyGet = ControlModel.DefaultText + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultValue") Then _PropertyGet = ControlModel.DefaultValue + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultDate") Then + Select Case VarType(ControlModel.DefaultDate) + Case vbLong ' AOO and LO <= 4.1 + vDefaultValue = ControlModel.DefaultDate + _PropertyGet = DateSerial(Left(vDefaultValue, 4), Mid(vDefaultValue, 5, 2), Right(vDefaultValue, 2)) + Case vbObject ' LO >= 4.2 com.sun.star.Util.Date + Set oDefaultValue = ControlModel.DefaultDate + _PropertyGet = DateSerial(oDefaultValue.Year,oDefaultValue.Month, oDefaultValue.Day) + Case vbEmpty + End Select + End If + Case CTLFORMATTEDFIELD + If Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then _PropertyGet = ControlModel.EffectiveDefault + Case CTLLISTBOX + If Utils._hasUNOProperty(ControlModel, "DefaultSelection") And Utils._hasUNOProperty(ControlModel, "StringItemList") Then + vDefaultValue = ControlModel.DefaultSelection + If IsArray(vDefaultValue) Then + If UBound(vDefaultValue) >= LBound(vDefaultValue) Then ' Is array initialized ? + iIndex = UBound(ControlModel.StringItemList) + If vDefaultValue(0) >= 0 And vDefaultValue(0) <= iIndex Then _PropertyGet = ControlModel.StringItemList(vDefaultValue(0)) + ' Only first default value is considered + End If + End If + End If + Case CTLSPINBUTTON + If Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then _PropertyGet = ControlModel.DefaultSpinValue + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "DefaultTime") Then + Select Case VarType(ControlModel.DefaultTime) + Case vbLong ' AOO and LO <= 4.1 + _PropertyGet = ControlModel.DefaultTime + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + Set oDefaultValue = ControlModel.DefaultTime + _PropertyGet = TimeSerial(oDefaultValue.Hours, oDefaultValue.Minutes, oDefaultValue.Seconds) + Case vbEmpty + End Select + End If + Case Else + Goto Trace_Error + End Select + Case UCase("Enabled") + If Utils._hasUNOProperty(ControlModel, "Enabled") Then _PropertyGet = ControlModel.Enabled + Case UCase("FontBold") + If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ( ControlModel.FontWeight >= com.sun.star.awt.FontWeight.BOLD ) + Case UCase("FontItalic") + If Utils._hasUNOProperty(ControlModel, "FontSlant") Then _PropertyGet = ( ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC ) + Case UCase("FontName") + If Utils._hasUNOProperty(ControlModel, "FontName") Then _PropertyGet = ControlModel.FontName + Case UCase("FontSize") + If Utils._hasUNOProperty(ControlModel, "FontHeight") Then _PropertyGet = ControlModel.FontHeight + Case UCase("FontUnderline") + If Utils._hasUNOProperty(ControlModel, "FontUnderline") Then _PropertyGet = _ + Not ( ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE _ + Or ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.DONTKNOW ) + Case UCase("FontWeight") + If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ControlModel.FontWeight + Case UCase("ForeColor") + If Utils._hasUNOProperty(ControlModel, "TextColor") Then _PropertyGet = ControlModel.TextColor + Case UCase("Form") + Set ofSubForm = New SubForm ' Start building the SUBFORM object + With ofSubForm + Set ._This = ofSubForm + Set .DatabaseForm = ControlModel + ._Name = _Name + ._Shortcut = _Shortcut & ".Form" + ._MainForm = _MainForm + .ParentComponent = _FormComponent + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + ._OrderBy = ControlModel.Order + End With + set _PropertyGet = ofSubForm + Case UCase("Format") + vFormats = _Formats(_Subtype) + Select Case _SubType + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "DateFormat") Then + If ControlModel.DateFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.DateFormat) + End If + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then + If ControlModel.TimeFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.TimeFormat) + End If + Case Else + If Utils._hasUNOProperty(ControlModel, "FormatKey") Then + If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then + _PropertyGet = ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString + End If + End If + End Select + Case UCase("ItemData") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + If IsMissing(pvIndex) Then + _PropertyGet = ControlModel.StringItemList + Else + If pvIndex < 0 Or pvIndex > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Index + _PropertyGet = ControlModel.StringItemList(pvIndex) + End If + End If + Case UCase("ListCount") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then _PropertyGet = UBound(ControlModel.StringItemList) + 1 + Case UCase("ListIndex") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + lListIndex = -1 ' Either Multiple selections or no selection at all + Select Case _SubType + Case CTLCOMBOBOX + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error + iIndex = 0 + If ControlModel.Text <> "" Then + For j = 0 To UBound(ControlModel.StringItemList) + If ControlModel.StringItemList(j) = ControlModel.Text Then + lListIndex = j + iIndex = iIndex + 1 + End If + Next j + If iIndex <> 1 Then lListIndex = -1 ' Multiselection or synonyms rejected + End If + Case CTLLISTBOX ' No mean found to access bound column !! See mail Lionel 10/5/2013 for improvement + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error + If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected + Else ' Mono selection + If _ParentType <> CTLPARENTISDIALOG Then ' getCurrentValue not found in dialog listboxes ?? + vCurrentValue = ControlModel.getCurrentValue() ' Space or uninitialized array if no selection at all + If IsArray(vCurrentValue) Then ' Is an array if MultiSelect + vListboxValue = "" + If UBound(vCurrentValue) = 0 Then vListboxValue = vCurrentValue(0) + Else + vListboxValue = vCurrentValue + End If + If vListboxValue <> "" Then ' Speed up search PM Pastim 12/02/2013 + If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) + End If + Else + If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) + End If + End If + End Select + _PropertyGet = lListIndex + End If + Case UCase("Locked") + If Utils._hasUNOProperty(ControlModel, "ReadOnly") Then _PropertyGet = ControlModel.ReadOnly + Case UCase("MultiSelect") + If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then + _PropertyGet = ControlModel.MultiSelection ' Boolean in OO, Integer (0, 1 or 2) in VBA + ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: only for GridControls !? Changed in OO >= 3,3 !? + _PropertyGet = ControlModel.MultiSelectionSimpleMode + Else + _PropertyGet = False + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _ + , UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _ + , UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _ + , UCase("OnUpdated") + Select Case _ParentType + Case CTLPARENTISDIALOG + Set oControlEvents = ControlModel.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty) + If oControlEvents.hasByName(sEventName) Then + _PropertyGet = oControlEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case Else + _PropertyGet = Utils._GetEventScriptCode(ControlModel, psProperty, _Name) + End Select + Case UCase("OptionValue") + If Utils._hasUNOProperty(ControlModel, "RefValue") Then + If ControlModel.RefValue <> "" Then + _PropertyGet = ControlModel.RefValue + ElseIf Utils._hasUNOProperty(ControlModel, "Label") Then + _PropertyGet = ControlModel.Label + End If + End If + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Page") + If Utils._hasUNOProperty(ControlModel, "Step") Then _PropertyGet = ControlModel.Step + Case UCase("Parent") + Set _PropertyGet = _Parent + Case UCase("Picture") + _PropertyGet = ConvertToUrl(ControlModel.ImageURL) + Case UCase("Required") + If Utils._hasUNOProperty(ControlModel, "InputRequired") Then _PropertyGet = ControlModel.InputRequired + Case UCase("RowSource") + Select Case _ParentType + Case CTLPARENTISDIALOG + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList) + _PropertyGet = Join(vListSource, ";") + End If + Case Else + If Utils._hasUNOProperty(ControlModel, "ListSource") Then + Select Case ControlModel.ListSourceType + Case com.sun.star.form.ListSourceType.VALUELIST _ + , com.sun.star.form.ListSourceType.TABLEFIELDS + If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList) + Case com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH + If IsArray(ControlModel.ListSource) Then vListSource = ControlModel.ListSource Else vListSource = Array(ControlModel.ListSource) + End Select + _PropertyGet = Join(vListSource, ";") + End If + End Select + Case UCase("RowSourceType") + If Utils._hasUNOProperty(ControlModel, "ListSourceType") Then _PropertyGet = ControlModel.ListSourceType + Case UCase("Selected") + If Utils._hasUNOProperty(ControlModel, "StringItemList") Then + lListIndex = UBound(ControlModel.StringItemList) + If Not IsMissing(pvIndex) Then + If pvIndex < 0 Or pvIndex > lListIndex Then Goto Trace_Error_Index + End If + If lListIndex < 0 Then ' Do nothing if listbox empty + _PropertyGet = Array() + Else + Redim bSelected(0 To lListIndex) + For j = 0 To lListIndex + bSelected(j) = False + Next j + For j = 0 To UBound(ControlModel.SelectedItems) + iIndex = ControlModel.SelectedItems(j) + If iIndex >= 0 And iIndex <= lListIndex Then bSelected(iIndex) = True + Next j + If IsMissing(pvIndex) Then _PropertyGet = bSelected Else _PropertyGet = bSelected(pvIndex) + End If + End If + Case UCase("SelLength") + If Utils._hasUNOProperty(ControlView, "Selection") Then + vSelection = ControlView.getSelection() + If vSelection.Max >= vSelection.Min Then + _PropertyGet = vSelection.Max - vSelection.Min + Else + _PropertyGet = 0 ' probably control does not have focus + End If + Else + _PropertyGet = 0 + End If + Case UCase("SelStart") + If Utils._hasUNOProperty(ControlView, "Selection") Then + vSelection = ControlView.getSelection() + If vSelection.Max >= vSelection.Min Then + _PropertyGet = vSelection.Min + 1 + Else + _PropertyGet = 1 ' probably control does not have focus + End If + Else + _PropertyGet = 1 + End If + Case UCase("SelText") + If Utils._hasUNOProperty(ControlView, "SelectedText") Then + _PropertyGet = ControlView.getSelectedText() + Else + _PropertyGet = "" + End If + Case UCase("SpecialEffect") + If Utils._hasUNOProperty(ControlModel, "VisualEffect") Then _PropertyGet = ControlModel.VisualEffect + Case UCase("SubType") + _PropertyGet = _SubType + Case UCase("TabIndex") + If Utils._hasUNOProperty(ControlModel, "TabIndex") Then _PropertyGet = ControlModel.TabIndex + Case UCase("TabStop") + If Utils._hasUNOProperty(ControlModel, "Tabstop") Then _PropertyGet = ControlModel.Tabstop + Case UCase("Tag") + If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag + Case UCase("Text") + Select Case _SubType + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "Date") Then + If Utils._hasUNOProperty(ControlModel, "FormatKey") Then + If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then + Select Case VarType(ControlModel.Date) + Case vbLong ' AOO and LO <= 4.1 + vDate = DateSerial(Left(ControlModel.Date, 4), Mid(ControlModel.Date, 5, 2), Right(ControlModel.Date, 2)) + Case vbObject ' LO >= 4.2 + vDate = DateSerial(ControlModel.Date.Year, ControlModel.Date.Month, ControlModel.Date.Day) + Case vbEmpty + End Select + _PropertyGet = Format(vDate, ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString) + End If + End If + End If + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "Text") Then + Select Case VarType(ControlModel.Time) + Case vbLong ' AOO and LO <= 4.1 + _PropertyGet = Format(ControlModel.Time, "HH:MM:SS") + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + Set oValue = ControlModel.Time + _PropertyGet = Format(TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds), "HH:MM:SS") + Case vbEmpty + End Select + End If + Case Else + If Utils._hasUNOProperty(ControlModel, "Text") Then _PropertyGet = ControlModel.Text + End Select + Case UCase("TextAlign") + If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag + Case UCase("TripleState") + If Utils._hasUNOProperty(ControlModel, "TriState") Then _PropertyGet = ControlModel.TriState + Case UCase("Value") + Select Case _SubType + Case CTLCHECKBOX + If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ControlModel.State + Case CTLCOMMANDBUTTON + vGet = False + If Utils._hasUNOProperty(ControlModel, "Toggle") Then + If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ( ControlModel.State = 1 ) + End If + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Utils._hasUNOProperty(ControlModel, "Text") Then vGet = ControlModel.Text + Case CTLCURRENCYFIELD + If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value + Case CTLDATEFIELD + If Utils._hasUNOProperty(ControlModel, "Date") Then + Select Case VarType(ControlModel.Date) + Case vbLong ' AOO and LO <= 4.1 + vValue = ControlModel.Date + vGet = DateSerial(Left(vValue, 4), Mid(vValue, 5, 2), Right(vValue, 2)) + Case vbObject ' LO >= 4.2 com.sun.star.Util.Date + Set oValue = ControlModel.Date + vGet = DateSerial(oValue.Year, oValue.Month, oValue.Day) + Case vbEmpty + End Select + End If + Case CTLFORMATTEDFIELD + If Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then vGet = ControlModel.EffectiveValue + Case CTLHIDDENCONTROL + If Utils._hasUNOProperty(ControlModel, "HiddenValue") Then vGet = ControlModel.HiddenValue + Case CTLLISTBOX + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error + If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected + vGet = EMPTY ' Listbox has no value, only an array of Selected flags to identify values + Else ' Mono selection + Select Case _ParentType + Case CTLPARENTISDIALOG + If Ubound(ControlModel.SelectedItems) >= 0 Then + lListIndex = Controlmodel.Selecteditems(0) + If lListIndex > -1 And lListIndex <= UBound(ControlModel.StringItemList) Then + vGet = ControlModel.StringItemList(lListIndex) + Else + vGet = EMPTY + End If + End If + Case Else + 'getCurrentValue does not return any significant value anymore + ' Speed up getting value PM PASTIM 12/02/2013 + If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) Else lListIndex = -1 + ' If listbox has hidden column = real bound field, then explore ValueItemList + If _ListboxBound() Then + If lListIndex > -1 Then vGet = ControlModel.ValueItemList(lListIndex) ' PASTIM + Else + If lListIndex > -1 Then vGet = ControlModel.getItemText(lListIndex) + End If + End Select + End If + Case CTLNUMERICFIELD + If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value + Case CTLPROGRESSBAR + If Utils._hasUNOProperty(ControlModel, "ProgressValue") Then vGet = ControlModel.ProgressValue + Case CTLSCROLLBAR + If Utils._hasUNOProperty(ControlModel, "ScrollValue") Then vGet = ControlModel.ScrollValue + Case CTLSPINBUTTON + If Utils._hasUNOProperty(ControlModel, "SpinValue") Then vGet = ControlModel.SpinValue + Case CTLTIMEFIELD + If Utils._hasUNOProperty(ControlModel, "Time") Then + Select Case VarType(ControlModel.Time) + Case vbLong ' AOO and LO <= 4.1 + vGet = ControlModel.Time + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + Set oValue = ControlModel.Time + vGet = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds) + Case vbEmpty + End Select + End If + Case Else + End Select + If _SubType <> CTLLISTBOX Then ' Give getCurrentValue an additional try + If IsEmpty(vGet) And Utils._hasUNOMethod(ControlModel, "getCurrentValue") Then vGet = ControlModel.getCurrentValue() + End If + _PropertyGet = vGet + Case UCase("Visible") + Select Case _SubType + Case CTLHIDDENCONTROL + _PropertyGet = False + Case Else + If Utils._hasUNOMethod(ControlView, "isVisible") Then _PropertyGet = CBool(ControlView.isVisible()) + End Select + Case Else + Goto Trace_Error + End Select + + If IsEmpty(_PropertyGet) Then TraceError(TRACEINFO, ERRPROPERTYINIT, Utils._CalledSub(), 0, , psProperty) + +Exit_Function: + Utils._ResetCalledSub("Control.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Control._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Control.set" & psProperty) + _PropertySet = True + +'Check Index argument + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function + End If +'Execute +Dim iArgNr As Integer, vButton As Variant, i As Integer +Dim odbDatabase As Object, vNames() As Variant, bFound As Boolean, sName As String +Dim bMultiSelect As Boolean, iCount As Integer, iSelectedItems() As Integer, lListCount As Long, bSelected() As Boolean +Dim vItemList() As Variant, vFormats() As Variant +Dim oStruct As Object, sValue As String +Dim vSelection As Variant, sText As String, lStart As long +Dim oControlEvents As Object, sListener As String, sEvent As String, sEventName As String, oEvent As Object + + _PropertySet = True + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("Control.setProperty") : iArgNr = 2 + Case UCase("Control.set" & psProperty) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("BackColor") + If Not Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.BackgroundColor = CLng(pvValue) + Case UCase("BorderColor") + If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.BorderColor = CLng(pvValue) + Case UCase("BorderStyle") + If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = No border, 1 = 3D border, 2 = Normal border + ControlModel.Border = CLng(pvValue) + Case UCase("Cancel") + If Not Utils._hasUNOProperty(ControlModel, "PushButtonType") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then vButton = com.sun.star.awt.PushButtonType.CANCEL Else vButton = com.sun.star.awt.PushButtonType.STANDARD + ControlModel.PushButtonType = vButton + Case UCase("Caption") + If Not Utils._hasUNOProperty(ControlModel, "Label") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.Label = pvValue + Case UCase("ControlTipText") + If Not Utils._hasUNOProperty(ControlModel, "HelpText") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.HelpText = pvValue + Case UCase("Default") + If Not Utils._hasUNOProperty(ControlModel, "DefaultButton") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.DefaultButton = pvValue + Case UCase("DefaultValue") + Select Case _SubType + Case CTLDATEFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultDate") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + Select Case VarType(ControlModel.DefaultDate) + Case vbEmpty, vbLong ' AOO and LO <= 4.1 + ControlModel.DefaultDate = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) + Case vbObject ' LO >= 4.2 com.sun.star.Util.Date + ControlModel.DefaultDate.Year = Year(pvValue) + ControlModel.DefaultDate.Month = Month(pvValue) + ControlModel.DefaultDate.Day = Day(pvValue) + End Select + Case CTLLISTBOX + If Not Utils._hasUNOProperty(ControlModel, "DefaultSelection") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + For i = 0 To UBound(ControlModel.StringItemList) + If UCase(pvValue) = UCase(ControlModel.StringItemList(i)) Then + ControlModel.DefaultSelection = Array(i) + Exit For + End If + Next i + Case CTLSPINBUTTON + If Not Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.DefaultSpinValue = pvValue + Case CTLCHECKBOX + If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know + ControlModel.DefaultState = pvValue + Case CTLRADIOBUTTON + If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 1 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked + ControlModel.DefaultState = pvValue + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultText") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.DefaultText = pvValue + Case CTLTIMEFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultTime") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue >= 0 And pvValue <= 23595999 Then + Select Case VarType(ControlModel.DefaultTime) + Case vbEmpty, vbLong ' AOO and LO <= 4.1 + ControlModel.DefaultTime = pvValue + Case vbObject ' LO >= 4.2 com.sun.star.Util.Time + ControlModel.DefaultDate.Hours = Hour(pvValue) + ControlModel.DefaultDate.Minutes = Minute(pvValue) + ControlModel.DefaultDate.Seconds = Second(pvValue) + End Select + Else Goto Trace_Error_Value + End If + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If Not Utils._hasUNOProperty(ControlModel, "DefaultValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.DefaultValue = pvValue + Case CTLFORMATTEDFIELD + If Not Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.EffectiveDefault = pvValue ' Thanks, PASTIM + Case Else + Goto Trace_Error + End Select + Case UCase("Enabled") + If Not Utils._hasUNOProperty(ControlModel, "Enabled") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.Enabled = pvValue + Case UCase("FontBold") + If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ' Iif construction does not work ! + ControlModel.FontWeight = com.sun.star.awt.FontWeight.BOLD + Else + ControlModel.FontWeight = com.sun.star.awt.FontWeight.NORMAL + End If + Case UCase("FontItalic") + If Not Utils._hasUNOProperty(ControlModel, "FontSlant") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ' Iif construction does not work ! + ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC + Else + ControlModel.FontSlant = com.sun.star.awt.FontSlant.NONE + End If + Case UCase("FontName") + If Not Utils._hasUNOProperty(ControlModel, "FontName") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.FontName = pvValue + Case UCase("FontSize") + If Not Utils._hasUNOProperty(ControlModel, "FontHeight") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Or pvValue > 127 Then Goto Trace_Error_Value + ControlModel.FontHeight = pvValue + Case UCase("FontUnderline") + If Not Utils._hasUNOProperty(ControlModel, "FontUnderline") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ' Iif construction does not work ! + ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.SINGLE + Else + ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE + End If + Case UCase("FontWeight") + If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error + If Not Utils._IsScalar(CSng(pvValue), vbSingle, Array( _ + com.sun.star.awt.FontWeight.THIN _ + , com.sun.star.awt.FontWeight.ULTRALIGHT _ + , com.sun.star.awt.FontWeight.LIGHT _ + , com.sun.star.awt.FontWeight.SEMILIGHT _ + , com.sun.star.awt.FontWeight.NORMAL _ + , com.sun.star.awt.FontWeight.SEMIBOLD _ + , com.sun.star.awt.FontWeight.BOLD _ + , com.sun.star.awt.FontWeight.ULTRABOLD _ + , com.sun.star.awt.FontWeight.BLACK _ + )) Then Goto Trace_Error_Value + ControlModel.FontWeight = pvValue + Case UCase("Format") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + vFormats = _Formats(_SubType) + Select Case _SubType + Case CTLDATEFIELD, CTLTIMEFIELD + bFound = False + For i = 0 To UBound(vFormats) + If UCase(pvValue) = UCase(vFormats(i)) Then + If _SubType = CTLDATEFIELD Then + If Utils._hasUNOProperty(ControlModel, "DateFormat") Then ControlModel.DateFormat = i Else Goto Trace_Error + Else + If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then ControlModel.TimeFormat = i Else Goto Trace_Error + End If + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_Error_Value + Case Else + Goto Trace_Error + End Select + Case UCase("ForeColor") + If Not Utils._hasUNOProperty(ControlModel, "TextColor") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.TextColor = CLng(pvValue) + Case UCase("ListIndex") + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Value + Select Case _SubType + Case CTLCOMBOBOX + ControlModel.Text = ControlModel.StringItemList(pvValue) + Case CTLLISTBOX + ControlModel.SelectedItems = Array(pvValue) + End Select + Case UCase("Locked") + If Not Utils._hasUNOProperty(ControlModel, "ReadOnly") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.ReadOnly = pvValue + Case UCase("MultiSelect") + If Not Utils._hasUNOProperty(ControlModel, "MultiSelection") And Not Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then + ControlModel.MultiSelection = pvValue + ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then + ControlModel.MultiSelectionSimpleMode = pvValue + End If + If Not pvValue Then ControlModel.SelectedItems = Array() ' Cancel selections when MultiSelect becomes False + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _ + , UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _ + , UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _ + , UCase("OnUpdated") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Select Case _ParentType + Case CTLPARENTISDIALOG + If Not Utils._RegisterDialogEventScript(ControlModel _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + ) Then GoTo Trace_Error + Case Else + If Not Utils._RegisterEventScript(ControlModel _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + , _Name _ + ) Then GoTo Trace_Error + End Select + Case UCase("OptionValue") + If Not Utils._hasUNOProperty(ControlModel, "RefValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Not Utils._hasUNOProperty(ControlModel, "Label") Then + If pvValue = "" Then Goto Trace_Error_Value + If ControlModel.RefValue <> "" Then ControlModel.RefValue = pvValue + Else + ControlModel.Label = pvValue + End If + Case UCase("Page") + If Not Utils._hasUNOProperty(ControlModel, "Step") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + ControlModel.Step = pvValue + Case UCase("Picture") + If Not Utils._hasUNOProperty(ControlModel, "ImageURL") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.ImageURL = ConvertToUrl(pvValue) + Case UCase("Required") + If Not Utils._hasUNOProperty(ControlModel, "InputRequired") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.InputRequired = pvValue + Case UCase("RowSource") + Select Case _ParentType + Case CTLPARENTISDIALOG + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + ControlModel.StringItemList = Split(pvValue, ";") + Case Else + If Not Utils._hasUNOProperty(ControlModel, "ListSource") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Select Case ControlModel.ListSourceType + Case com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.TABLEFIELDS + Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + If ControlModel.ListSourceType = com.sun.star.form.ListSourceType.QUERY Then vNames = odbDatabase.Connection.getQueries.GetElementNames _ + Else vNames = odbDatabase.Connection.getTables.GetElementNames + bFound = False ' Check existence of table or query and find its correct (case-sensitive) name + For i = 0 To UBound(vNames) + If UCase(vNames(i)) = UCase(pvValue) Then + bFound = True + sName = vNames(i) + Exit For + End If + Next i + If Not bFound Then Goto Trace_Error_Value + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = sName Else ControlModel.ListSource = Array(sName) + ControlModel.refresh() + Case com.sun.star.form.ListSourceType.SQL + Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = odbDatabase._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(odbDatabase._ReplaceSquareBrackets(pvValue)) + ControlModel.refresh() + Case com.sun.star.form.ListSourceType.VALUELIST ' Forbidden for COMBOBOX ! + If _SubType = CTLCOMBOBOX Then Goto Trace_Error + ControlModel.ListSource = Split(pvValue, ";") + ControlModel.StringItemList = ControlModel.ListSource + Case com.sun.star.form.ListSourceType.SQLPASSTHROUGH + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = pvValue Else ControlModel.ListSource = Array(pvValue) + ControlModel.refresh() + End Select + End Select + If _SubType = CTLLISTBOX Then ControlModel.SelectedItems = Array() + Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType + If Not Utils._hasUNOProperty(ControlModel, "ListSourceType") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Not Utils._IsScalar(pvValue, Utils._AddNumeric(), Array( _ + com.sun.star.form.ListSourceType.VALUELIST _ + , com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + , com.sun.star.form.ListSourceType.TABLEFIELDS _ + )) Then Goto Trace_Error_Value + ControlModel.ListSourceType = pvValue + Case UCase("Selected") + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error + If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error + If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then + bMultiSelect = ControlModel.MultiSelection + ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then + bMultiSelect = ControlModel.MultiSelectionSimpleMode + Else: Goto Trace_Error + End If + lListCount = UBound(ControlModel.StringItemList) + 1 + If IsMissing(pvIndex) Then ' Full boolean array passed + If Not IsArray(pvValue) Then Goto Trace_Error_Array + If LBound(pvValue) <> 0 Or UBound(pvValue) < 0 Then Goto Trace_Error_Array + If Not Utils._CheckArgument(pvValue(0), iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If UBound(pvValue) <> lListCount - 1 Then Goto Trace_Error_Index + iCount = 0 + For i = 0 To UBound(pvValue) ' Count True values + If pvValue(i) Then iCount = iCount + 1 + Next i + If iCount > 0 Then + Redim iSelectedItems(0 To iCount - 1) + iCount = 0 + For i = 0 To UBound(pvValue) + If pvValue(i) Then + iSelectedItems(iCount) = i + iCount = iCount + 1 + End If + Next i + ControlModel.SelectedItems = iSelectedItems ' iSelectedItems maps OO internals (size = # of selected items) + Else + ControlModel.SelectedItems = Array() + End If + Else ' Single boolean value passed + If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < 0 Or pvIndex >= lListCount Then Goto Trace_Error_Index + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ReDim bSelected(0 To lListCount - 1) ' bSelected maps VBA internals (size = # of displayed items) + If Not bMultiSelect Then ' Set all other values to False + For i = 0 To lListCount - 1 + If i = pvIndex Then + bSelected(i) = pvValue ' All entries = False except one + Else + bSelected(i) = False + End If + Next i + Else + For i = 0 To lListCount - 1 + bSelected(i) = False + Next i + iSelectedItems = ControlModel.SelectedItems + iCount = UBound(iSelectedItems) + For i = 0 To iCount + bSelected(iSelectedItems(i)) = True + Next i + bSelected(pvIndex) = pvValue + End If + iCount = 0 ' Rebuild SelectedItems + For i = 0 To lListCount - 1 + If bSelected(i) Then iCount = iCount + 1 + Next i + If iCount > 0 Then + Redim iSelectedItems(0 To iCount - 1) + iCount = 0 + For i = 0 To lListCount - 1 + If bSelected(i) Then + iSelectedItems(iCount) = i + iCount = iCount + 1 + End If + Next i + ControlModel.SelectedItems = iSelectedItems + Else + ControlModel.SelectedItems = Array() + End If + End If + Case UCase("SelLength") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + vSelection = ControlView.getSelection() + vSelection.Max = vSelection.Min + pvValue + ControlView.setSelection(vSelection) + Case UCase("SelStart") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Or pvValue > Len(ControlModel.Text) + 1 Then Goto Trace_Error_Value + vSelection = ControlView.getSelection() + vSelection.Min = pvValue - 1 + vSelection.Max = pvValue - 1 ' Also reset length to 0 + ControlView.setSelection(vSelection) + Case UCase("SelText") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Len(pvValue) > 0 Then + vSelection = ControlView.getSelection() + sText = ControlModel.Text + lStart = InStr(1, sText, pvValue, 0) ' Case sensitive ! + If lStart > 0 Then + vSelection.Min = lStart - 1 + vSelection.Max = lStart + Len(pvValue) - 1 + ControlView.setSelection(vSelection) + End If + End If + Case UCase("SpecialEffect") + If Not Utils._hasUNOProperty(ControlModel, "VisualEffect") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = None, 1 = Look3D, 2 = Flat + ControlModel.VisualEffect = pvValue + Case UCase("TabIndex") + If Not Utils._hasUNOProperty(ControlModel, "TabIndex") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -1 Then Goto Trace_Error_Value + ControlModel.TabIndex = pvValue + Case UCase("TabStop") + If Not Utils._hasUNOProperty(ControlModel, "Tabstop") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.Tabstop = pvValue + Case UCase("Tag") + If Not Utils._hasUNOProperty(ControlModel, "Tag") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.Tag = pvValue + Case UCase("TextAlign") + If Not Utils._hasUNOProperty(ControlModel, "Align") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Left, 1 = Center, 2 = Right + ControlModel.Align = pvValue + Case UCase("TripleState") + If Not Utils._hasUNOProperty(ControlModel, "TriState") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ControlModel.TriState = pvValue + Case UCase("Value") + Select Case _SubType + Case CTLCHECKBOX + If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbBoolean), , False) Then Goto Trace_Error_Value + If VarType(pvValue) = vbBoolean Then pvValue = Iif(pvValue, 1, 0) + If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know + ControlModel.State = pvValue + Case CTLCOMMANDBUTTON + If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error + If Not Utils._hasUNOProperty(ControlModel, "Toggle") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ControlModel.State = 1 Else ControlModel.State = 0 + Case CTLCOMBOBOX + If Not Utils._hasUNOProperty(ControlModel, "Text") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ + Then Goto Trace_Error + If pvValue <> "" Then + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, ControlModel.StringItemList, False) Then Goto Trace_Error_Value + End If + ControlModel.Text = pvValue + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If Not Utils._hasUNOProperty(ControlModel, "Value") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + ControlModel.Value = pvValue + Case CTLDATEFIELD + If Not Utils._hasUNOProperty(ControlModel, "Date") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + Select Case _InspectPropertyType(ControlModel, "Date") + Case "long" ' AOO and LO <= 4.1 + 'ControlModel.Date = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) ' Gives error in dialogs ?!? + ControlModel.setPropertyValue("Date", Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue)) + Case "com.sun.star.util.Date" ' LO >= 4.2 + 'Direct assignment of ControlModel.Date.Xxx has no effect ?!? + Set oStruct = CreateUnoStruct("com.sun.star.util.Date") + oStruct.Year = Year(pvValue) + oStruct.Month = Month(pvValue) + oStruct.Day = Day(pvValue) + Set ControlModel.Date = oStruct + End Select + Case CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + ControlModel.Text = pvValue + Case CTLFORMATTEDFIELD + If Not Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbString), , False) Then Goto Trace_Error_Value + ControlModel.EffectiveValue = pvValue + Case CTLHIDDENCONTROL + If Not Utils._hasUNOProperty(ControlModel, "HiddenValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbBoolean, vbDate)), , False) Then Goto Trace_Error_Value + ControlModel.HiddenValue = pvValue + Case CTLLISTBOX + If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ + Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbDate)), , False) Then Goto Trace_Error_Value ' PASTIM + If IsArray(pvValue) Then Goto Trace_Error_Value ' Setting the value on a listbox is allowed only if single value and value in the list + ' Check ValueItemList + bFound = False + Select Case _ParentType + Case CTLPARENTISDIALOG + vItemList = ControlModel.StringItemList + Case Else + If _ListboxBound() Then ' Performance improvement (PASTIM PM 9 Feb 2013) + If Not Utils._hasUNOProperty(ControlModel, "ValueItemList") Then Goto Trace_Error + vItemList = ControlModel.ValueItemList + Else + vItemList = ControlModel.StringItemList + End If + End Select + For i = 0 To UBound(vItemList) + If pvValue = vItemList(i) Then + bFound = True + Exit For + End If + Next i + If bFound Then ControlModel.SelectedItems = Array(i) Else Goto Trace_Error_Value + Case CTLPROGRESSBAR + If Not Utils._hasUNOProperty(ControlModel, "ProgressValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "ProgressValueMin") Then + If pvValue < ControlModel.ProgressValueMin Then Goto Trace_Error_Value + End If + If Utils._hasUNOProperty(ControlModel, "ProgressValueMax") Then + If pvValue > ControlModel.ProgressValueMax Then Goto Trace_Error_Value + End If + ControlModel.ProgressValue = pvValue + Case CTLSCROLLBAR + If Not Utils._hasUNOProperty(ControlModel, "ScrollValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "ScrollValueMin") Then + If pvValue < ControlModel.ScrollValueMin Then Goto Trace_Error_Value + End If + If Utils._hasUNOProperty(ControlModel, "ScrollValueMax") Then + If pvValue > ControlModel.ScrollValueMax Then Goto Trace_Error_Value + End If + ControlModel.ScrollValue = pvValue + Case CTLSPINBUTTON + If Not Utils._hasUNOProperty(ControlModel, "SpinValue") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ControlModel, "SpinValueMin") Then + If pvValue < ControlModel.SpinValueMin Then Goto Trace_Error_Value + End If + If Utils._hasUNOProperty(ControlModel, "SpinValueMax") Then + If pvValue > ControlModel.SpinValueMax Then Goto Trace_Error_Value + End If + ControlModel.SpinValue = pvValue + Case CTLTIMEFIELD + If Not Utils._hasUNOProperty(ControlModel, "Time") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + Select Case _InspectPropertyType(ControlModel, "Time") + Case "long" ' AOO and LO <= 4.0 + ControlModel.Time = CLng(pvValue) + Case "com.sun.star.util.Time" ' LO >= 4.1 + 'Direct assignment of ControlModel.Time.Xxx gives error ?!? + Set oStruct = CreateUnoStruct("com.sun.star.util.Time") + sValue = Right("00000000" & Str(CLng(pvValue)), 8) + oStruct.Hours = Val(Left(sValue, 2)) + oStruct.Minutes = Val(Mid(sValue, 3, 2)) + oStruct.Seconds = Val(Mid(sValue, 5, 2)) + Set ControlModel.Time = oStruct + End Select + Case Else + Goto Trace_Error + End Select + ' FINAL COMMITMENT + If Utils._hasUNOMethod(ControlModel, "commit") Then ControlModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM] + Case UCase("Visible") + If _SubType = CTLHIDDENCONTROL Then Goto Trace_Error ' Hidden remains hidden !! + If Not Utils._hasUNOMethod(ControlView, "setVisible") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ControlModel.EnableVisible = True + ControlView.setVisible(pvValue) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Control.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Array: + TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Control._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet V1.1.0 + + diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba new file mode 100644 index 000000000..8cc6b9bb1 --- /dev/null +++ b/wizards/source/access2base/DataDef.xba @@ -0,0 +1,598 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be TABLEDEF or QUERYDEF +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String ' For tables: [[Catalog.]Schema.]Table +Private _ParentDatabase As Object +Private _ReadOnly As Boolean +Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable +Private CatalogName As String +Private SchemaName As String +Private TableName As String +Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery +Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable +Private TableFieldsCount As Integer +Private TableKeysCount As Integer + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = "" + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + Set _ParentDatabase = Nothing + _ReadOnly = False + Set Table = Nothing + CatalogName = "" + SchemaName = "" + TableName = "" + Set Query = Nothing + Set TableDescriptor = Nothing + TableFieldsCount = 0 + TableKeysCount = 0 +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SQL() As Variant + SQL = _PropertyGet("SQL") +End Property ' SQL (get) + +Property Let SQL(ByVal pvValue As Variant) + Call _PropertySet("SQL", pvValue) +End Property ' SQL (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function pType() As Integer + pType = _PropertyGet("Type") +End Function ' Type (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function CreateField(ByVal Optional pvFieldName As Variant _ + , ByVal optional pvType As Variant _ + , ByVal optional pvSize As Variant _ + , ByVal optional pvAttributes As Variant _ + ) As Object +'Return a Field object +Const cstThisSub = "TableDef.CreateField" + Utils._SetCalledSub(cstThisSub) + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object +Const cstMaxKeyLength = 30 + + CreateField = Nothing + If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvFieldName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function + If pvFieldName = "" Then Call _TraceArguments() + If IsMissing(pvType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _ + dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _ + , dbNumeric, dbDecimal, dbText, dbChar, dbMemo _ + , dbDate, dbTime, dbTimeStamp _ + , dbBinary, dbVarBinary, dbLongBinary, dbBoolean _ + )) Then Goto Exit_Function + If IsMissing(pvSize) Then pvSize = 0 + If pvSize < 0 Then pvSize = 0 + If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function + If IsMissing(pvAttributes) Then pvAttributes = 0 + If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function + + If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable + If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable + + If _ReadOnly Then Goto Error_NoUpdate + + Set oNewField = New Field + With oNewField + ._This = oNewField + ._Name = pvFieldName + ._ParentName = _Name + ._ParentType = OBJTABLEDEF + If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table + Set .Column = oTable.Columns.createDataDescriptor() + End With + With oNewField.Column + .Name = pvFieldName + Select Case pvType + Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT + Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER + Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT + Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT + Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL + Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE + Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC + Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL + Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR + Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR + Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR + Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE + Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME + Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP + Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY + Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY + Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY + Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN + End Select + .Precision = Int(pvSize) + If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10 + .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE + If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName + If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName + If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName + If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1 + If pvAttributes = dbAutoIncrField Then + If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists + Set oKeys = oTable.Keys + Set oPrimaryKey = oKeys.createDataDescriptor() + Set oColumn = oPrimaryKey.Columns.createDataDescriptor() + oColumn.Name = pvFieldName + oColumn.CatalogName = CatalogName + oColumn.SchemaName = SchemaName + oColumn.TableName = TableName + oColumn.IsAutoIncrement = True + oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS + oPrimaryKey.Columns.appendByDescriptor(oColumn) + oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength) + oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY + oKeys.appendByDescriptor(oPrimaryKey) + .IsAutoIncrement = True + .IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS + oColumn.dispose() + Else + .IsAutoIncrement = False + End If + End With + oTable.Columns.appendByDescriptor(oNewfield.Column) + + Set CreateField = oNewField + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' CreateField V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean +'Execute a stored query. The query must be an ACTION query. + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".Execute" + Utils._SetCalledSub(cstThisSub) + On Local Error Goto Error_Function +Const cstNull = -1 + Execute = False + If _Type <> OBJQUERYDEF Then Goto Trace_Method + If IsMissing(pvOptions) Then + pvOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function + End If + + 'Check action query +Dim oStatement As Object, vResult As Variant +Dim iType As Integer, sSql As String + iType = pType + If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action + + 'Execute action query + Set oStatement = _ParentDatabase.Connection.createStatement() + sSql = Query.Command + If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _ + Else oStatement.EscapeProcessing = Query.EscapeProcessing + On Local Error Goto SQL_Error + vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql)) + On Local Error Goto Error_Function + + Execute = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Method: + TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub) + Goto Exit_Function +Trace_Action: + TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name) + Goto Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' Execute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Fields(ByVal Optional pvIndex As Variant) As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".Fields" + Utils._SetCalledSub(cstThisSub) + + Set Fields = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oFields As Object + + If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns() + sObjects = oFields.ElementNames() + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLFIELDS + Set oObject._Parent = _This + oObject._Count = UBound(sObjects) + 1 + Goto Exit_Function + Case VarType(pvIndex) = vbString + bFound = False + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + End Select + + Set oObject = New Field + Set oObject._This = oObject + oObject._Name = sObjectName + Set oObject.Column = oFields.getByName(sObjectName) + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oObject._ParentDatabase = _ParentDatabase + +Exit_Function: + Set Fields = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Fields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".getProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".hasProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Utils._ResetCalledSub(cstThisSub) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object +'Return a Recordset object based on current table- or querydef object + +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" + Utils._SetCalledSub(cstThisSub) +Const cstNull = -1 +Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean +Dim iType As Integer, iOptions As Integer, iLockEdit As Integer + + + Set oObject = Nothing + If VarType(pvType) = vbError Then + iType = cstNull + ElseIf IsMissing(pvType) Then + iType = cstNull + Else + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function + iType = pvType + End If + If VarType(pvOptions) = vbError Then + iOptions = cstNull + ElseIf IsMissing(pvOptions) Then + iOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + iOptions = pvOptions + End If + If VarType(pvLockEdit) = vbError Then + iLockEdit = cstNull + ElseIf IsMissing(pvLockEdit) Then + iLockEdit = cstNull + Else + If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function + iLockEdit = pvLockEdit + End If + + Select Case _Type + Case OBJTABLEDEF + lCommandType = com.sun.star.sdb.CommandType.TABLE + sCommand = _Name + Case OBJQUERYDEF + lCommandType = com.sun.star.sdb.CommandType.QUERY + sCommand = _Name + If iOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing + End Select + + Set oObject = New Recordset + With oObject + ._CommandType = lCommandType + ._Command = sCommand + ._ParentName = _Name + ._ParentType = _Type + ._ForwardOnly = ( iType = dbOpenForwardOnly ) + ._PassThrough = bPassThrough + ._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly ) + Set ._ParentDatabase = _ParentDatabase + Set ._This = oObject + Call ._Initialize() + End With + With _ParentDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + +Exit_Function: + Set OpenRecordset = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set oObject = Nothing + GoTo Exit_Function +End Function ' OpenRecordset V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".Properties" + Utils._SetCalledSub(cstThisSub) + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + Set vProperty._ParentDatabase = _ParentDatabase + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".setProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + Select Case _Type + Case OBJTABLEDEF + _PropertiesList = Array("Name", "ObjectType") + Case OBJQUERYDEF + _PropertiesList = Array("Name", "ObjectType", "SQL", "Type") + Case Else + End Select + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) + Utils._SetCalledSub(cstThisSub & ".get" & psProperty) +Dim sSql As String, sVerb As String, iType As Integer + _PropertyGet = EMPTY + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("SQL") + _PropertyGet = Query.Command + Case UCase("Type") + iType = 0 + sSql = Utils._Trim(UCase(Query.Command)) + sVerb = Split(sSql, " ")(0) + If sVerb = "SELECT" Then iType = iType + dbQSelect + If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 _ + Or sVerb = "CREATE" And InStr(sSql, " TABLE ") > 0 _ + Then iType = iType + dbQMakeTable + If sVerb = "SELECT" And InStr(sSql, " UNION ") > 0 Then iType = iType + dbQSetOperation + If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough + If sVerb = "INSERT" Then iType = iType + dbQAppend + If sVerb = "DELETE" Then iType = iType + dbQDelete + If sVerb = "UPDATE" Then iType = iType + dbQUpdate + If sVerb = "CREATE" _ + Or sVerb = "ALTER" _ + Or sVerb = "DROP" _ + Or sVerb = "RENAME" _ + Or sVerb = "TRUNCATE" _ + Then iType = iType + dbQDDL + ' dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate + ' To check Type use: If (iType And dbQxxx) <> 0 Then ... + _PropertyGet = iType + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & ".get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) + Utils._SetCalledSub(cstThisSub & ".set" & psProperty) + +'Execute +Dim iArgNr As Integer + + _PropertySet = True + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase(cstThisSub & ".setProperty") : iArgNr = 2 + Case UCase(cstThisSub & ".set" & psProperty) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + If _ReadOnly Then Goto Error_NoUpdate + + Select Case UCase(psProperty) + Case UCase("SQL") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Query.Command = pvValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & ".set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba new file mode 100644 index 000000000..347eafeb4 --- /dev/null +++ b/wizards/source/access2base/Database.xba @@ -0,0 +1,1889 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be DATABASE +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _DbConnect As Integer ' DBCONNECTxxx constants +Private Title As String +Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj +Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection +Private URL As String +Private Location As String ' Different from URL for registered databases +Private _ReadOnly As Boolean +Private MetaData As Object ' interface XDatabaseMetaData +Private _RDBMS As Integer ' DBMS constants +Private _ColumnTypes() As Variant ' Part of Metadata.GetTypeInfo() +Private _ColumnTypeNames() As Variant +Private _ColumnPrecisions() As Variant +Private _ColumnTypesReference() As Variant +Private _ColumnTypesAlias() As Variant ' To what should a field whose origin is another DBMS be converted ? See DataTypes By RDBMS.ods +Private _BinaryStream As Boolean ' False = binary fields must NOT be streamed f.i. via ReadAllBytes or WriteAllBytes +Private Form As Object ' com.sun.star.form.XForm +Private FormName As String +Private RecordsetMax As Long ' To make unique names in Collection below (See bug # 121342) +Private RecordsetsColl As Object ' Collection of active recordsets + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJDATABASE + Set _This = Nothing + Set _Parent = Nothing + _DbConnect = 0 + Title = "" + Set Document = Nothing + Set Connection = Nothing + URL = "" + _ReadOnly = False + Set MetaData = Nothing + _RDBMS = DBMS_UNKNOWN + _ColumnTypes = Array() + _ColumnTypeNames = Array() + _ColumnPrecisions = Array() + _ColumnTypesReference = Array() + _ColumnTypesAlias() = Array() + _BinaryStream = False + Set Form = Nothing + FormName = "" + RecordsetMax = 0 + Set RecordsetsColl = New Collection +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call CloseAllRecordsets() + If _DbConnect <> DBCONNECTANY Then + If Not IsNull(Connection) Then + Connection.close() + Connection.dispose() + Set Connection = Nothing + End If + Else + mClose() + End If + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + + + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get Connect() As String + Connect = _PropertyGet("Connect") +End Property ' Connect (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnCreate() As String + OnCreate = _PropertyGet("OnCreate") +End Property ' OnCreate (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocus() As String + OnFocus = _PropertyGet("OnFocus") +End Property ' OnFocus (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoad() As String + OnLoad = _PropertyGet("OnLoad") +End Property ' OnLoad (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoadFinished() As String + OnLoadFinished = _PropertyGet("OnLoadFinished") +End Property ' OnLoadFinished (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnModifyChanged() As String + OnModifyChanged = _PropertyGet("OnModifyChanged") +End Property ' OnModifyChanged (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnNew() As String + OnNew = _PropertyGet("OnNew") +End Property ' OnNew (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnPrepareUnload() As String + OnPrepareUnload = _PropertyGet("OnPrepareUnload") +End Property ' OnPrepareUnload (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnPrepareViewClosing() As String + OnPrepareViewClosing = _PropertyGet("OnPrepareViewClosing") +End Property ' OnPrepareViewClosing (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSave() As String + OnSave = _PropertyGet("OnSave") +End Property ' OnSave (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveAs() As String + OnSaveAs = _PropertyGet("OnSaveAs") +End Property ' OnSaveAs (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveAsDone() As String + OnSaveAsDone = _PropertyGet("OnSaveAsDone") +End Property ' OnSaveAsDone (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveAsFailed() As String + OnSaveAsFailed = _PropertyGet("OnSaveAsFailed") +End Property ' OnSaveAsFailed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveDone() As String + OnSaveDone = _PropertyGet("OnSaveDone") +End Property ' OnSaveDone (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSaveFailed() As String + OnSaveFailed = _PropertyGet("OnSaveFailed") +End Property ' OnSaveFailed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSubComponentClosed() As String + OnSubComponentClosed = _PropertyGet("OnSubComponentClosed") +End Property ' OnSubComponentClosed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnSubComponentOpened() As String + OnSubComponentOpened = _PropertyGet("OnSubComponentOpened") +End Property ' OnSubComponentOpened (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnTitleChanged() As String + OnTitleChanged = _PropertyGet("OnTitleChanged") +End Property ' OnTitleChanged (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnfocus() As String + OnUnfocus = _PropertyGet("OnUnfocus") +End Property ' OnUnfocus (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnload() As String + OnUnload = _PropertyGet("OnUnload") +End Property ' OnUnload (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnViewClosed() As String + OnViewClosed = _PropertyGet("OnViewClosed") +End Property ' OnViewClosed (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnViewCreated() As String + OnViewCreated = _PropertyGet("OnViewCreated") +End Property ' OnViewCreated (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Version() As String + Version = _PropertyGet("Version") +End Property ' Version (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose() As Variant +' Close the database + +If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Database.Close" + Utils._SetCalledSub(cstThisSub) + mClose = False + If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable + + With Connection + If Utils._hasUNOMethod(Connection, "flush") Then .flush + .close() + .dispose() + End With + Set Connection = Nothing + mClose = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' (m)Close + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub CloseAllRecordsets() +' Clean all recordsets for housekeeping + +Dim sRecordsets() As String, i As Integer, oRecordset As Object + On Local Error Goto Exit_Sub + + If IsNull(RecordsetsColl) Then Exit Sub + If RecordsetsColl.Count < 1 Then Exit Sub + For i = 1 To RecordsetsColl.Count + Set oRecordset = RecordsetsColl.Item(i) + oRecordset.mClose(False) ' Do not remove entry in collection + Next i + Set RecordsetsColl = New Collection + RecordsetMax = 0 + +Exit_Sub: + Exit Sub +End Sub ' CloseAllRecordsets V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _ + , ByVal Optional pvSql As Variant _ + , ByVal Optional pvOption As Variant _ + ) As Object +'Return a (new) QueryDef object based on SQL statement +Const cstThisSub = "Database.CreateQueryDef" + Utils._SetCalledSub(cstThisSub) + +Const cstNull = -1 +Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set CreateQueryDef = Nothing + If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvQueryName) Then Call _TraceArguments() + If IsMissing(pvSql) Then Call _TraceArguments() + If IsMissing(pvOption) Then pvOption = cstNull + + If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function + If pvQueryName = "" Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function + If pvSql = "" Then Call _TraceArguments() + If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + + If _ReadOnly Then Goto Error_NoUpdate + + Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition") + oQuery.rename(pvQueryName) + oQuery.Command = _ReplaceSquareBrackets(pvSql) + oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) + + Set oQueries = Document.DataSource.getQueryDefinitions() + With oQueries + For i = 0 To .getCount() - 1 + sQueryName = .getByIndex(i).Name + If UCase(sQueryName) = UCase(pvQueryName) Then + TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName) + .removeByName(sQueryName) + Exit For + End If + Next i + .insertByName(pvQueryName, oQuery) + End With + Set CreateQueryDef = QueryDefs(pvQueryName) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CreateQueryDef V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object +'Return a (new/empty) TableDef object +Const cstThisSub = "Database.CreateTableDef" + Utils._SetCalledSub(cstThisSub) + +Dim oTable As Object, oTables As Object, sTables() As String +Dim i As Integer, sTableName As String, oNewTable As Object +Dim vNameComponents() As Variant, iNames As Integer + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set CreateTableDef = Nothing + If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvTableName) Then Call _TraceArguments() + + If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function + If pvTableName = "" Then Call _TraceArguments() + + If _ReadOnly Then Goto Error_NoUpdate + + Set oTables = Connection.getTables + With oTables + sTables = .ElementNames() + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sTables) + If UCase(pvTableName) = UCase(sTables(i)) Then + sTableName = sTables(i) + TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName) + .dropByName(sTableName) + Exit For + End If + Next i + Set oNewTable = New DataDef + Set oNewTable._This = oNewTable + oNewTable._Type = OBJTABLEDEF + oNewTable._Name = pvTableName + vNameComponents = Split(pvTableName, ".") + iNames = UBound(vNameComponents) + If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = "" + If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = "" + oNewtable.TableName = vNameComponents(iNames) + Set oNewTable._ParentDatabase = _This + Set oNewTable.TableDescriptor = .createDataDescriptor() + oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName + oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName + oNewTable.TableDescriptor.Name = oNewTable.TableName + oNewTable.TableDescriptor.Type = "TABLE" + End With + + Set CreateTabledef = oNewTable + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CreateTableDef V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DAvg( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return average of scope +Const cstThisSub = "Database.DAvg" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DAvg + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DCount( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return # of occurrences of scope +Const cstThisSub = "Database.DCount" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DLookup( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + +' Return a value within a table + 'Arguments: psExpr: an SQL expression + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + 'Return: Value of the psExpr if found, else Null. + 'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html + 'Examples: + ' 1. To find the last value, include DESC in the OrderClause, e.g.: + ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC") + ' 2. To find the lowest non-null value of a field, use the Criteria, e.g.: + ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname") + +Const cstThisSub = "Database.DLookup" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DLookup = _DFunction("", psExpr, psDomain _ + , Iif(IsMissing(pvCriteria), "", pvCriteria) _ + , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _ + ) + Utils._ResetCalledSub(cstThisSub) +End Function ' DLookup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMax( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return maximum of scope +Const cstThisSub = "Database.DMax" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMax + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMin( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return minimum of scope +Const cstThisSub = "Database.DMin" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMin + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDev( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "Database.DStDev" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDev + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDevP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "Database.DStDevP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDevP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DSum( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return sum of scope +Const cstThisSub = "Database.DSum" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DSum + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVar( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "Database.DVar" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVarP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "Database.DVarP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVarP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Database.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Database.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenRecordset(ByVal Optional pvSource As Variant _ + , ByVal Optional pvType As Variant _ + , ByVal Optional pvOptions As Variant _ + , ByVal Optional pvLockEdit As Variant _ + ) As Object +'Return a Recordset object based on Source (= SQL, table or query name) + +Const cstThisSub = "Database.OpenRecordset" + Utils._SetCalledSub(cstThisSub) +Const cstNull = -1 + +Dim lCommandType As Long, sCommand As String, oObject As Object +Dim sSource As String, i As Integer, iCount As Integer +Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object +Dim iType As Integer, iOptions As Integer, iLockEdit As Integer + + If _ErrorHandler() Then On Local Error Goto Error_Function + Set oObject = Nothing + If IsMissing(pvSource) Then Call _TraceArguments() + If pvSource = "" Then Call _TraceArguments() + If VarType(pvType) = vbError Then + iType = cstNull + ElseIf IsMissing(pvType) Then + iType = cstNull + Else + If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function + iType = pvType + End If + If VarType(pvOptions) = vbError Then + iOptions = cstNull + ElseIf IsMissing(pvOptions) Then + iOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + iOptions = pvOptions + End If + If VarType(pvLockEdit) = vbError Then + iLockEdit = cstNull + ElseIf IsMissing(pvLockEdit) Then + iLockEdit = cstNull + Else + If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function + iLockEdit = pvLockEdit + End If + + sSource = Split(UCase(Trim(pvSource)), " ")(0) + Select Case True + Case sSource = "SELECT" + lCommandType = com.sun.star.sdb.CommandType.COMMAND + sCommand = _ReplaceSquareBrackets(pvSource) + Case Else + sSource = UCase(Trim(pvSource)) + REM Explore tables + Set oTables = Connection.getTables + sObjects = oTables.ElementNames() + bFound = False + For i = 0 To UBound(sObjects) + If sSource = UCase(sObjects(i)) Then + sCommand = sObjects(i) + bFound = True + Exit For + End If + Next i + If bFound Then + lCommandType = com.sun.star.sdb.CommandType.TABLE + Else + REM Explore queries + Set oQueries = Connection.getQueries + sObjects = oQueries.ElementNames() + For i = 0 To UBound(sObjects) + If sSource = UCase(sObjects(i)) Then + sCommand = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + lCommandType = com.sun.star.sdb.CommandType.QUERY + End If + End Select + + Set oObject = New Recordset + With oObject + ._CommandType = lCommandType + ._Command = sCommand + ._ParentName = Title + ._ParentType = _Type + ._ForwardOnly = ( iType = dbOpenForwardOnly ) + ._PassThrough = ( iOptions = dbSQLPassThrough ) + ._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly ) + Set ._This = oObject + Set ._ParentDatabase = _This + Call ._Initialize() + RecordsetMax = RecordsetMax + 1 + ._Name = Format(RecordsetMax, "0000000") + RecordsetsColl.Add(oObject, UCase(._Name)) + End With + + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + +Exit_Function: + Set OpenRecordset = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource)) + Goto Exit_Function +End Function ' OpenRecordset V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain a SELECT query +' pvOption can force pass through mode + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Database.OpenSQL" + Utils._SetCalledSub(cstThisSub) + + OpenSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function + End If + If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable + +Dim oURL As New com.sun.star.util.URL, oDispatch As Object +Dim vArgs(8) as New com.sun.star.beans.PropertyValue + + oURL.Complete = ".component:DB/DataSourceBrowser" + oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8) + + vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = Connection + vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND + vArgs(2).Name = "Command" : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL) + vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True + vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False + vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False + vArgs(6).Name = "Filter" : vArgs(6).Value = "" + vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False + vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough )) + + oDispatch.dispatch(oURL, vArgs) + OpenSQL = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenSQL", Erl) + GoTo Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' OpenSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OutputTo(ByVal pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvOutputFormat As Variant _ + , ByVal Optional pvOutputFile As Variant _ + , ByVal Optional pvAutoStart As Variant _ + , ByVal Optional pvTemplateFile As Variant _ + , ByVal Optional pvEncoding As Variant _ + , ByVal Optional pvQuality As Variant _ + , ByRef Optional pvHeaders As Variant _ + , ByRef Optional pvData As Variant _ + ) As Boolean +'Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries +'pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Database.OutputTo" + Utils._SetCalledSub(cstThisSub) + + OutputTo = False + + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function + If IsMissing(pvObjectName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvOutputFormat) Then pvOutputFormat = "" + If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function + If pvOutputFormat <> "" Then + If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ + UCase(acFormatHTML), "HTML" _ + , UCase(acFormatODS), "ODS" _ + , UCase(acFormatXLS), "XLS" _ + , UCase(acFormatXLSX), "XLSX" _ + , UCase(acFormatTXT), "TXT", "CSV" _ + , "")) _ + Then Goto Exit_Function ' A 2nd time to allow case unsensitivity + End If + If IsMissing(pvOutputFile) Then pvOutputFile = "" + If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function + If IsMissing(pvAutoStart) Then pvAutoStart = False + If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function + If IsMissing(pvTemplateFile) Then pvTemplateFile = "" + If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function + If IsMissing(pvEncoding) Then pvEncoding = 0 + If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function + If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint + If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function + If pvObjectType = acOutputArray Then + If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments() + pvOutputFormat = "HTML" + End If + +Dim sOutputFile As String, oTable As Object +Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String + + If pvObjectType = acOutputArray Then + Set oTable = Nothing + Else + 'Find applicable table or query + If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True) + If IsNull(oTable) Then Goto Error_NotFound + End If + + 'Determine format and parameters + If pvOutputFormat = "" Then + sOutputFormat = _PromptFormat(Array("HTML", "ODS", "XLS", "XLSX", "TXT")) ' Prompt user for format + If sOutputFormat = "" Then Goto Exit_Function + Else + sOutputFormat = UCase(pvOutputFormat) + End If + + 'Determine output file + If pvOutputFile = "" Then ' Prompt file picker to user + Select Case sOutputFormat + Case UCase(acFormatHTML), "HTML" : sSuffix = "html" + Case UCase(acFormatODS), "ODS" : sSuffix = "ods" + Case UCase(acFormatXLS), "XLS" : sSuffix = "xls" + Case UCase(acFormatXLSX), "XLSX" : sSuffix = "xlsx" + Case UCase(acFormatTXT), "TXT", "CSV" : sSuffix = "txt" + End Select + sOutputFile = _PromptFilePicker(sSuffix) + If sOutputFile = "" Then Goto Exit_Function + Else + sOutputFile = pvOutputFile + End If + sOutputFile = ConvertToURL(sOutputFile) + + 'Create file + Select Case sOutputFormat + Case UCase(acFormatHTML), "HTML" + If pvObjectType = acOutputArray Then + bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData) + Else + bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile) + End If + Case UCase(acFormatODS), "ODS" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS) + Case UCase(acFormatXLS), "XLS" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS) + Case UCase(acFormatXLS), "XLSX" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX) + Case UCase(acFormatTXT), "TXT", "CSV" + bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding) + End Select + + 'Launch application, if requested + If bOutput Then + If pvAutoStart Then Call _ShellExecute(sOutputFile) + Else + GoTo Error_File + End If + + OutputTo = True + +Exit_Function: + If Not IsNull(oTable) Then + oTable.Dispose() + Set oTable = Nothing + End If + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_File: + TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile) + GoTo Exit_Function +End Function ' OutputTo V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + + Utils._SetCalledSub("Database.Properties") +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + Set vProperty._ParentDatabase = _This + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub("Database.Properties") + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object +' Collect all Queries in the database +' pbCheck unpublished + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Database.QueryDefs") + If IsMissing(pbCheck) Then pbCheck = False + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oQueries As Object + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + Set oQueries = Connection.getQueries + sObjects = oQueries.ElementNames() + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLQUERYDEFS + Set oObject._Parent = _This + oObject._Count = UBound(sObjects) + 1 + Goto Exit_Function + Case VarType(pvIndex) = vbString + bFound = False + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + End Select + + Set oObject = New DataDef + Set oObject._This = oObject + oObject._Type = OBJQUERYDEF + oObject._Name = sObjectName + Set oObject._ParentDatabase = _This + oObject._readOnly = _ReadOnly + Set oObject.Query = oQueries.getByName(sObjectName) + +Exit_Function: + Set QueryDefs = oObject + Set oObject = Nothing + Utils._ResetCalledSub("Database.QueryDefs") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl) + GoTo Exit_Function +Trace_NotFound: + If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' QueryDefs V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object +' Collect all active recordsets + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Database.Recordsets") + + Set Recordsets = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oTables As Object + + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLRECORDSETS + Set oObject._Parent = _This + oObject._Count = RecordsetsColl.Count + Case VarType(pvIndex) = vbString + bFound = _hasRecordset(pvIndex) + If Not bFound Then Goto Trace_NotFound + Set oObject = RecordsetsColl.Item(pvIndex) + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex >= RecordsetsColl.Count Then Goto Trace_IndexError + Set oObject = RecordsetsColl.Item(pvIndex + 1) ' Collection members are numbered 1 ... Count + End Select + +Exit_Function: + Set Recordsets = oObject + Set oObject = Nothing + Utils._ResetCalledSub("Database.Recordsets") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Database.Recordsets", Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Recordsets V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RunSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain an ACTION query + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Database.RunSQL" + Utils._SetCalledSub(cstThisSub) + + RunSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + +Dim oStatement As Object, vResult As Variant + Set oStatement = Connection.createStatement() + oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) + On Local Error Goto SQL_Error + vResult = oStatement.execute(_ReplaceSquareBrackets(pvSQL)) + On Local Error Goto Error_Function + RunSQL = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) + Goto Exit_Function +End Function ' RunSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object +' Collect all tables in the database +' pbCheck unpublished + +Const cstThisSub = "Database.TableDefs" + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + If IsMissing(pbCheck) Then pbCheck = False + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oTables As Object + Set oObject = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + + Set oTables = Connection.getTables + sObjects = oTables.ElementNames() + Select Case True + Case IsMissing(pvIndex) + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLTABLEDEFS + Set oObject._Parent = _This + oObject._Count = UBound(sObjects) + 1 + Goto Exit_Function + Case VarType(pvIndex) = vbString + bFound = False + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + Case Else ' pvIndex is numeric + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + End Select + + Set oObject = New DataDef + With oObject + ._This = oObject + ._Type = OBJTABLEDEF + ._Name = sObjectName + Set ._ParentDatabase = _This + ._ReadOnly = _ReadOnly + Set .Table = oTables.getByName(sObjectName) + .CatalogName = .Table.CatalogName + .SchemaName = .Table.SchemaName + .TableName = .Table.Name + End With + +Exit_Function: + Set TableDefs = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' TableDefs V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DFunction(ByVal psFunction As String _ + , ByVal psExpr As String _ + , ByVal psDomain As String _ + , ByVal pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + 'Arguments: psFunction an optional aggregate function + ' psExpr: an SQL expression [might contain an aggregate function] + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + +If _ErrorHandler() Then On Local Error GoTo Error_Function + +Dim oResult As Object 'To retrieve the value to find. +Dim vResult As Variant 'Return value for function. +Dim sSql As String 'SQL statement. +Dim oStatement As Object 'For CreateStatement method +Dim sExpr As String 'For inclusion of aggregate function +Dim sTempField As String 'Random temporary field in SQL expression + +Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String +Dim sProductName As String + + vResult = Null + + Randomize 2^14-1 + sTempField = "[TEMP" & Right("00000" & Int(100000 * Rnd), 5) & "]" + If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = "" + If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = "" + sLimit = "" + + sProductName = UCase(MetaData.getDatabaseProductName()) + + Select Case sProductName + Case "MYSQL", "SQLITE" + If psFunction = "" Then + sTarget = psExpr + sLimit = " LIMIT 1" + Else + sTarget = UCase(psFunction) & "(" & psExpr & ")" + End If + sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy & sLimit + Case "FIREBIRD (ENGINE12)" + If psFunction = "" Then sTarget = "FIRST 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")" + sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy + Case Else ' Standard syntax - Includes HSQLDB + If psFunction = "" Then sTarget = "TOP 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")" + sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy + End Select + + 'Lookup the value. + Set oStatement = Connection.createStatement() + With oStatement + .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + .EscapeProcessing = False + sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string + Set oResult = .executeQuery(sSql) + If Not IsNull(oResult) And Not IsEmpty(oResult) Then + If Not oResult.next() Then Goto Exit_Function + vResult = Utils._getResultSetColumnValue(oResult, 1, True) ' Force return of binary field + End If + End With + +Exit_Function: + 'Assign the returned value. + _DFunction = vResult + Set oResult = Nothing + Set oStatement = Nothing + Exit Function +Error_Function: + TraceError(TRACEFATAL, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) + Goto Exit_Function +End Function ' DFunction V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String +' Return the default FilterOptions string for table/query export to csv + +Dim sFieldSeparator as string +Const cstComma = "," +Const cstTextDelimitor = """" + + If _DecimalPoint() = "," Then sFieldSeparator = ";" Else sFieldSeparator = cstComma + _FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _ + & cstComma & Trim(Str(Asc(cstTextDelimitor))) _ + & cstComma & Trim(Str(plEncoding)) _ + & cstComma & "1" + +End Function ' _FilterOptionsDefault V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasRecordset(ByVal psName As String) As Boolean +' Return True if psName if in the collection of Recordsets + +Dim oRecordset As Object + If _ErrorHandler() Then On Local Error Goto Error_Function + Set oRecordset = RecordsetsColl.Item(psName) + _hasRecordset = True + +Exit_Function: + Exit Function +Error_Function: ' Item by key aborted + _hasRecordset = False + GoTo Exit_Function +End Function ' _hasRecordset V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _LoadMetadata() +' Load essentially getTypeInfo() results from Metadata + +Dim sProduct As String +Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer + +Const cstMaxInfo = 40 + ReDim _ColumnTypes(0 To cstMaxInfo) + ReDim _ColumnTypeNames(0 To cstMaxInfo) + ReDim _ColumnPrecisions(0 To cstMaxInfo) +Const cstHSQLDB1 = "HSQL Database Engine 1." +Const cstHSQLDB2 = "HSQL Database Engine 2." +Const cstFirebird = "sdbc:embedded:firebird" +Const cstMSAccess2003 = "MS Jet 0" +Const cstMSAccess2007 = "MS Jet 04." +Const cstMYSQL = "MySQL" +Const cstPOSTGRES = "PostgreSQL" +Const cstSQLITE = "SQLite" + + With com.sun.star.sdbc.DataType + _ColumnTypesReference = Array( _ + .ARRAY _ + , .BIGINT _ + , .BINARY _ + , .BIT _ + , .BLOB _ + , .BOOLEAN _ + , .CHAR _ + , .CLOB _ + , .DATE _ + , .DECIMAL _ + , .DISTINCT _ + , .DOUBLE _ + , .FLOAT _ + , .INTEGER _ + , .LONGVARBINARY _ + , .LONGVARCHAR _ + , .NUMERIC _ + , .OBJECT _ + , .OTHER _ + , .REAL _ + , .REF _ + , .SMALLINT _ + , .SQLNULL _ + , .STRUCT _ + , .TIME _ + , .TIMESTAMP _ + , .TINYINT _ + , .VARBINARY _ + , .VARCHAR _ + ) + End With + + With Metadata + sProduct = .getDatabaseProductName() & " " & .getDatabaseProductVersion + Select Case True + Case Len(sProduct) > Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1 + _RDBMS = DBMS_HSQLDB1 + _ColumnTypesAlias = Array(0, -5, -2, 16, -4, 16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2 + _RDBMS = DBMS_HSQLDB2 + _ColumnTypesAlias = Array(0, -5, -3, -7, 2004, 16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3, 12) + _BinaryStream = True + Case .URL = cstFirebird ' Only embedded 3.0 + _RDBMS = DBMS_FIREBIRD + _ColumnTypesAlias = Array(0, -5, -2, 16, 2004, 16, 1, 2005, 91, 3, 0, 8, 6, 4, -4, 2005, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, 4, 2004, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007 + _RDBMS = DBMS_MSACCESS2007 + _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003 + _RDBMS = DBMS_MSACCESS2003 + _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL + _RDBMS = DBMS_MYSQL + _ColumnTypesAlias = Array(0, -5, -2, -7, -4, -7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, -1) + _BinaryStream = False + Case Len(sProduct) > Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES + _RDBMS = DBMS_POSTGRES + _ColumnTypesAlias = Array(0, -5, -3, 16, -3, 16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12) + _BinaryStream = True + Case Len(sProduct) > Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE + _RDBMS = DBMS_SQLITE + _ColumnTypesAlias = Array(0, -5, -4, -7, -4, -7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4, 12) + _BinaryStream = True + Case Else + _RDBMS = DBMS_UNKNOWN + _BinaryStream = True + End Select + + iInfo = -1 + Set oTypeInfo = MetaData.getTypeInfo() + With oTypeInfo + .next() + Do While Not .isAfterLast() And iInfo < cstMaxInfo + sName = .getString(1) + lType = .getLong(2) + If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) <> "_" Or lType <> -1) Then ' Skip + Else + iInfo = iInfo + 1 + _ColumnTypeNames(iInfo) = sName + _ColumnTypes(iInfo) = lType + _ColumnPrecisions(iInfo) = CLng(.getLong(3)) + End If + .next() + Loop + End With + ReDim Preserve _ColumnTypes(0 To iInfo) + ReDim Preserve _ColumnTypeNames(0 To iInfo) + ReDim Preserve _ColumnPrecisions(0 To iInfo) + End With + +End Sub ' _LoadMetadata V1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputBinaryToHTML() As String +' Converts Binary value to HTML compatible string + + _OutputBinaryToHTML = "&nbsp;" + +End Function ' _OutputBinaryToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String +' Converts input boolean value to HTML compatible string + + _OutputBooleanToHTML = Iif(pbBool, "&#x2714;", "&#x2716;") ' ✔ and ✖ + +End Function ' _OutputBooleanToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputClassToHTML(ByVal pvArray As Variant) As String +' Formats classes attribute of <tr> and <td> tags + + If Not IsArray(pvArray) Then + _OutputClassToHTML = "" + ElseIf UBound(pvArray) < LBound(pvArray) Then + _OutputClassToHTML = "" + Else + _OutputClassToHTML = " class=""" & Join(pvArray, " ") & """" + End If + +End Function ' _OutputClassToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _ + , ByRef Optional pvHeaders As Variant _ + , ByRef Optional pvData As Variant _ + ) As Boolean +' Write html tags around data found in pvTable +' Exit when error without execution stop (to avoid file remaining open ...) + +Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer +Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant +Dim bDataArray As Boolean, sHeader As String +Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer +Const cstMaxRows = 200 + On Local Error GoTo Error_Function + + bDataArray = IsNull(pvTable) + Print #piFile, " <table class=""dbdatatable"">" + Print #piFile, " <caption>" & pvName & "</caption>" + + vFieldsBin() = Array() + If bDataArray Then + Set oTableRS = Nothing + iNumFields = UBound(pvHeaders) + 1 + ReDim vFieldsBin(0 To iNumFields - 1) + For i = 0 To iNumFields - 1 + vFieldsBin(i) = False + Next i + Else + Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly) + iNumFields = oTableRS.Fields.Count + ReDim vFieldsBin(0 To iNumFields - 1) + With com.sun.star.sdbc.DataType + For i = 0 To iNumFields - 1 + iDataType = oTableRS.Fields(i).DataType + vFieldsBin(i) = Utils._IsBinaryType(iDataType) + Next i + End With + End If + + With oTableRS + Print #piFile, " <thead>" + Print #piFile, " <tr>" + For i = 0 To iNumFields - 1 + If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name + Print #piFile, " <th scope=""col"">" & sHeader & "</th>" + Next i + Print #piFile, " </tr>" + Print #piFile, " </thead>" + Print #piFile, " <tfoot>" + Print #piFile, " </tfoot>" + + Print #piFile, " <tbody>" + If bDataArray Then + iLastRow = UBound(pvData, 2) + 1 + Else + .MoveLast + iLastRow = .RecordCount + .MoveFirst + End If + iCountRows = 0 + Do While iCountRows < iLastRow + If bDataArray Then + iNumRows = iLastRow + Else + vData() = .GetRows(cstMaxRows) + iNumRows = UBound(vData, 2) + 1 + End If + For j = 0 To iNumRows - 1 + iCountRows = iCountRows + 1 + vTrClass() = Array() + If iCountRows = 1 Then vTrClass() = _AddArray(vTrClass, "firstrow") + If iCountRows = iLastRow Then vTrClass() = _AddArray(vTrClass, "lastrow") + If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, "even") Else vTrClass() = _AddArray(vTrClass, "odd") + Print #piFile, " <tr" & _OutputClassToHTML(vTrClass) & ">" + For i = 0 To iNumFields - 1 + vTdClass() = Array() + If i = 0 Then vTdClass() = _AddArray(vTdClass, "firstcol") + If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, "lastcol") + If Not vFieldsBin(i) Then + If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j) + If vDataCell Is Nothing Then vDataCell = Null ' Necessary because Null object has not a VarType = vbNull + If VarType(vDataCell) = vbString Then ' Null string gives IsDate = True ! + If Len(vDataCell) > 0 And IsDate(vDataCell) Then vDataCell = CDate(vDataCell) + End If + Select Case VarType(vDataCell) + Case vbEmpty, vbNull + vTdClass() = _AddArray(vTdClass, "null") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNullToHTML() & "</td>" + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt + vTdClass() = _AddArray(vTdClass, "numeric") + If vDataCell < 0 Then vTdClass() = _AddArray(vTdClass, "negative") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNumberToHTML(vDataCell) & "</td>" + Case vbBoolean + vTdClass() = _AddArray(vTdClass, "bool") + If vDataCell = False Then vTdClass() = _AddArray(vTdClass, "false") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBooleanToHTML(vDataCell) & "</td>" + Case vbDate + vTdClass() = _AddArray(vTdClass, "date") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputDateToHTML(vDataCell) & "</td>" + Case vbString + vTdClass() = _AddArray(vTdClass, "char") + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputStringToHTML(vDataCell) & "</td>" + Case Else + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _CStr(vDataCell) & "</td>" + End Select + Else ' Binary fields + Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBinaryToHTML() & "</td>" + End If + Next i + Print #piFile, " </tr>" + Next j + Loop + + If Not bDataArray Then .mClose() + End With + Set oTableRS = Nothing + + Print #piFile, " </tbody>" + Print #piFile, " </table>" + _OutputDataToHTML = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEWARNING, Err, "_OutputDataToHTML", Erl) + _OutputDataToHTML = False + Resume Exit_Function +End Function ' _OutputDataToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputDateToHTML(ByVal psDate As Date) As String +' Converts input date to HTML compatible string + + _OutputDateToHTML = Format(psDate) ' With regional settings - Ignores time if = to 0 + +End Function ' _OutputDateToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputNullToHTML() As String +' Converts Null value to HTML compatible string + + _OutputNullToHTML = "&nbsp;" + +End Function ' _OutputNullToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String +' Converts input number to HTML compatible string + +Dim vNumber As Variant + If IsMissing(piPrecision) Then piPrecision = -1 + If pvNumber = Int(pvNumber) Then + vNumber = Int(pvNumber) + Else + If piPrecision >= 0 Then vNumber = (Int(pvNumber * 10 ^ piPrecision + 0.5)) / 10 ^ piPrecision Else vNumber = pvNumber + End If + _OutputNumberToHTML = Format(vNumber) + +End Function ' _OutputNumberToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputStringToHTML(ByVal psString As String) As String +' Converts input string to HTML compatible string +' - UTF-8 encoding +' - recognition of next patterns +' - &quot; - &amp; - &apos; - &lt; - &gt; +' - <pre> +' - <a href="... +' - <br> +' - <img src="... +' - <b>, <u>, <i> + +Dim vPatterns As Variant +Dim lCurrentChar as Long, lPattern As Long, lNextPattern As Long, sPattern As String +Dim sOutput As String, sChar As String +Dim sUrl As String, lNextQuote As Long, lUrl As Long, bQuote As Boolean, bTagEnd As Boolean +Dim i As Integer, l As Long + + vPatterns = Array( _ + "&quot;", "&amp;", "&apos;", "&lt;", "&gt;", "&nbsp;" _ + , "<pre>", "</pre>", "<br>" _ + , "<a href=""", "<a id=""", "</a>", "<img src=""" _ + , "<span class=""", "</span>" _ + , "<b>", "</b>", "<u>", "</u>", "<i>", "</i>" _ + ) + + lCurrentChar = 1 + sOutput = "" + + Do While lCurrentChar <= Len(psString) + ' Where is next closest pattern ? + lPattern = Len(psString) + 1 + sPattern = "" + For i = 0 To UBound(vPatterns) + lNextPattern = InStr(lCurrentChar, psString, vPatterns(i), 1) ' Text (not case-sensitive) string comparison + If lNextPattern > 0 And lNextPattern < lPattern Then + lPattern = lNextPattern + sPattern = Mid(psString, lPattern, Len(vPatterns(i))) + End If + Next i + ' Up to the next pattern or to the end of the string, UTF8-encode each character + For l = lCurrentChar To lPattern - 1 + sChar = Mid(psString, l, 1) + sOutput = sOutput & Utils._UTF8Encode(sChar) + Next l + ' Process hyperlink patterns and keep others + If Len(sPattern) > 0 Then + Select Case LCase(sPattern) + Case "<a href=""", "<a id=""", "<img src=""", "<span class=""" + ' Up to next quote, url-encode + lNextQuote = 0 + lUrl = lPattern + Len(sPattern) + lNextQuote = InStr(lUrl, psString, """", 1) + If lNextQuote = 0 Then lNextQuote = Len(psString) ' Should not happen but, if quoted string not closed ... + sUrl = Mid(psString, lUrl, lNextQuote - lUrl) + sOutput = sOutput & sPattern & sUrl & """" + lCurrentChar = lNextQuote + 1 + bQuote = False + bTagEnd = False + Do + sChar = Mid(psString, lCurrentChar, 1) + Select Case sChar + Case """" + bQuote = Not bQuote + sOutput = sOutput & sChar + Case ">" ' Tag end if not somewhere between quotes + If Not bQuote Then + bTagEnd = True + sOutput = sOutput & sChar + Else + sOutput = sOutput & _UTF8Encode(sChar) + End If + Case Else + sOutput = sOutput & _UTF8Encode(sChar) + End Select + lCurrentChar = lCurrentChar + 1 + If lCurrentChar > Len(psString) Then bTagEnd = True ' Should not happen but, if tag not closed ... + Loop Until bTagEnd + Case Else + sOutput = sOutput & sPattern + lCurrentChar = lPattern + Len(sPattern) + End Select + Else + lCurrentChar = Len(psString) + 1 + End If + Loop + + _OutputStringToHTML = sOutput + +End Function ' _OutputStringToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OutputToCalc(poData As Object _ + , ByVal psOutputFile As String _ + , ByVal psFilter As String _ + , Optional ByVal plEncoding As Long _ + ) As Boolean +' https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Database_Import +' https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options + +Dim oCalcDoc As Object, oSheet As Object, vWin As Variant +Dim vImportDesc() As Variant, iSource As Integer +Dim oRange As Object, i As Integer, iCol As Integer, oColumns As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + _OutputToCalc = False + If IsMissing(plEncoding) Then plEncoding = acUTF8Encoding + ' Create a new OO-Calc-Document + Set oCalcDoc = StarDesktop.LoadComponentFromURL( _ + "private:factory/scalc" _ + , "_default" ,0, Array() _ + ) + + ' Get the unique spreadsheet + Set oSheet = oCalcDoc.Sheets(0) + + ' Describe import + With poData + If ._Type = "TABLEDEF" Then + iSource = com.sun.star.sheet.DataImportMode.TABLE + Else + iSource = com.sun.star.sheet.DataImportMode.QUERY + End If + vImportDesc = Array( _ + _MakePropertyValue("DatabaseName", URL) _ + , _MakePropertyValue("SourceType", iSource) _ + , _MakePropertyValue("SourceObject", ._Name) _ + ) + oSheet.Name = ._Name + End With + + ' Import + oSheet.getCellByPosition(0, 0).doImport(vImportDesc()) + + Select Case psFilter + Case acFormatODS, acFormatXLS, acFormatXLSX ' Formatting + iCol = poData.Fields().Count + Set oRange = oSheet.getCellRangeByPosition(0, 0, iCol - 1, 0) + oRange.CharWeight = com.sun.star.awt.FontWeight.BOLD + oRange.CellBackColor = RGB(200, 200, 200) + oRange.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER + Set oColumns = oRange.getColumns() + For i = 0 To iCol - 1 + oColumns.getByIndex(i).OptimalWidth = True + Next i + oCalcDoc.storeAsUrl(psOutputFile, Array( _ + _MakePropertyValue("FilterName", psFilter) _ + , _MakePropertyValue("Overwrite", True) _ + )) + Case Else + oCalcDoc.storeAsUrl(psOutputFile, Array( _ + _MakePropertyValue("FilterName", psFilter) _ + , _MakePropertyValue("FilterOptions", _FilterOptionsDefault(plEncoding)) _ + , _MakePropertyValue("Overwrite", True) _ + )) + End Select + + oCalcDoc.close(False) + _OutputToCalc = True + +Exit_Function: + Set oColumns = Nothing + Set oRange = Nothing + Set oSheet = Nothing + Set oCalcDoc = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) + Goto Exit_Function +End Function ' OutputToCalc V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _OutputToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal psOutputFile As String, ByVal psTemplateFile As String _ + , ByRef Optional pvHeaders As Variant _ + , ByRef Optional pvData As Variant _ + ) As Boolean +' http://www.ehow.com/how_5652706_create-html-template-ms-access.html + +Dim bDataArray As Boolean +Dim vMinimalTemplate As Variant, vTemplate As Variant +Dim iFile As Integer, i As Integer, sLine As String, lBody As Long +Const cstTitle = "<!--Template_Title-->", cstBody = "<!--Template_Body-->" +Const cstTitleAlt = "<!--AccessTemplate_Title-->", cstBodyAlt = "<!--AccessTemplate_Body-->" + + On Local Error GoTo Error_Function + vMinimalTemplate = Array( _ + "<!DOCTYPE html>" _ + , "<html>" _ + , " <head>" _ + , " <title>" & cstTitle & "</title>" _ + , " </head>" _ + , " <body>" _ + , " " & cstBody _ + , " </body>" _ + , "</html>" _ + ) + + vTemplate = _ReadFileIntoArray(psTemplateFile) + If LBound(vTemplate) > UBound(vTemplate) Then vTemplate() = vMinimalTemplate() + + bDataArray = IsNull(pvTable) + +' Write output file + iFile = FreeFile() + Open psOutputFile For Output Access Write Lock Read Write As #iFile + For i = 0 To UBound(vTemplate) + sLine = vTemplate(i) + sLine = Join(Split(sLine, cstTitleAlt), cstTitle) + sLine = Join(Split(sLine, cstBodyAlt), cstBody) + Select Case True + Case InStr(sLine, cstTitle) > 0 + sLine = Join(Split(sLine, cstTitle), pvName) + Print #iFile, sLine + Case InStr(sLine, cstBody) > 0 + lBody = InStr(sLine, cstBody) + If lBody > 1 Then Print #iFile, Left(sLine, lBody - 1) + If bDataArray Then + _OutputDataToHTML(pvTable, pvName, iFile, pvHeaders, pvData) + Else + _OutputDataToHTML(pvTable, pvName, iFile) + End If + If Len(sLine) > lBody + Len(cstBody) - 1 Then Print #iFile, Right(sLine, Len(sLine) - lBody + Len(cstBody) + 1) + Case Else + Print #iFile, sLine + End Select + Next i + Close #iFile + + _OutputToHTML = True + +Exit_Function: + Exit Function +Error_Function: + _OutputToHTML = False + GoTo Exit_Function +End Function ' _OutputToHTML V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("Connect", "Name", "ObjectType" _ + , "OnCreate", "OnFocus", "OnLoad", "OnLoadFinished", "OnModifyChanged" _ + , "OnNew", "OnPrepareUnload", "OnPrepareViewClosing", "OnSave", "OnSaveAs" _ + , "OnSaveAsDone", "OnSaveAsFailed", "OnSaveDone", "OnSaveFailed", "OnSaveTo" _ + , "OnSaveToDone", "OnSaveToFailed", "OnSubComponentClosed", "OnSubComponentOpened" _ + , "OnTitleChanged", "OnUnfocus", "OnUnload", "OnViewClosed", "OnViewCreated" _ + , "Version" _ + ) + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + +Dim i As Integer, vEvents As Variant, sEvent As String, vEvent As Variant + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Database.get" & psProperty) + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("Connect") + If IsNull(Document) Then _PropertyGet = "" Else _PropertyGet = Document.Datasource.URL + ' Location = ConvertFromUrl(URL) + Case UCase("Name") + _PropertyGet = Title + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnCreate"), UCase("OnFocus"), UCase("OnLoad"), UCase("OnLoadFinished"), UCase("OnModifyChanged") _ + , UCase("OnNew"), UCase("OnPrepareUnload"), UCase("OnPrepareViewClosing"), UCase("OnSave"), UCase("OnSaveAs") _ + , UCase("OnSaveAsDone"), UCase("OnSaveAsFailed"), UCase("OnSaveDone"), UCase("OnSaveFailed"), UCase("OnSaveTo") _ + , UCase("OnSaveToDone"), UCase("OnSaveToFailed"), UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") _ + , UCase("OnTitleChanged"), UCase("OnUnfocus"), UCase("OnUnload"), UCase("OnViewClosed"), UCase("OnViewCreated") + ' Find script event + sEvent = "" + If IsNull(Document) Then vEvents = Array() Else vEvents = Document.getEvents().ElementNames ' Returns an array + For i = 0 To UBound(vEvents) + If UCase(vEvents(i)) = UCase(psProperty) Then + sEvent = vEvents(i) + Exit For + End If + Next i + If sEvent = "" Then + _PropertyGet = "" + Else + vEvent = Document.getEvents().getByName(sEvent) + If IsEmpty(vEvent) Then + _PropertyGet = "" + ElseIf vEvent(0).Value <> "Script" Then + _PropertyGet = "" + Else + _PropertyGet = vEvent(1).Value + End If + End If + Case UCase("Version") + _PropertyGet = MetaData.getDatabaseProductName() & " " & MetaData.getDatabaseProductVersion + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Database.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Database._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String +' Returns psSql after substitution of [] by quote character +' [] square brackets in (single) quoted strings not affected + +Dim sQuote As String 'RDBMS specific quote character +Dim vSubStrings() As Variant, i As Integer +Const cstSingleQuote = "'" + + sQuote = MetaData.IdentifierQuoteString + If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported. + _ReplaceSquareBrackets = Trim(psSql) + Exit Function + End If + vSubStrings() = Split(psSql, cstSingleQuote) + For i = 0 To UBound(vSubStrings) + If (i Mod 2) = 0 Or (i = UBound(vSubStrings)) Then ' Only even substrings are parsed for square brackets. Last substring is parsed anyway + vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote) + vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote) + End If + Next i + + _ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote)) + +End Function ' ReplaceSquareBrackets V1.1.0 + + \ No newline at end of file diff --git a/wizards/source/access2base/Dialog.xba b/wizards/source/access2base/Dialog.xba new file mode 100644 index 000000000..69caed33c --- /dev/null +++ b/wizards/source/access2base/Dialog.xba @@ -0,0 +1,818 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be DIALOG +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Shortcut As String +Private _Dialog As Object ' com.sun.star.io.XInputStreamProvider +Private _Storage As String ' GLOBAL or DOCUMENT +Private _Library As String +Private UnoDialog As Object ' com.sun.star.awt.XControl + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJDIALOG + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + Set _Dialog = Nothing + _Storage = "" + _Library = "" + Set UnoDialog = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Height() As Variant + Height = _PropertyGet("Height") +End Property ' Height (get) + +Property Let Height(ByVal pvValue As Variant) + Call _PropertySet("Height", pvValue) +End Property ' Height (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get IsLoaded() As Boolean + IsLoaded = _PropertyGet("IsLoaded") +End Property + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' OnFocusGained (get) + +Property Let OnFocusGained(ByVal pvValue As Variant) + Call _PropertySet("OnFocusGained", pvValue) +End Property ' OnFocusGained (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' OnFocusLost (get) + +Property Let OnFocusLost(ByVal pvValue As Variant) + Call _PropertySet("OnFocusLost", pvValue) +End Property ' OnFocusLost (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' OnKeyPressed (get) + +Property Let OnKeyPressed(ByVal pvValue As Variant) + Call _PropertySet("OnKeyPressed", pvValue) +End Property ' OnKeyPressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' OnKeyReleased (get) + +Property Let OnKeyReleased(ByVal pvValue As Variant) + Call _PropertySet("OnKeyReleased", pvValue) +End Property ' OnKeyReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' OnMouseDragged (get) + +Property Let OnMouseDragged(ByVal pvValue As Variant) + Call _PropertySet("OnMouseDragged", pvValue) +End Property ' OnMouseDragged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' OnMouseEntered (get) + +Property Let OnMouseEntered(ByVal pvValue As Variant) + Call _PropertySet("OnMouseEntered", pvValue) +End Property ' OnMouseEntered (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' OnMouseExited (get) + +Property Let OnMouseExited(ByVal pvValue As Variant) + Call _PropertySet("OnMouseExited", pvValue) +End Property ' OnMouseExited (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' OnMouseMoved (get) + +Property Let OnMouseMoved(ByVal pvValue As Variant) + Call _PropertySet("OnMouseMoved", pvValue) +End Property ' OnMouseMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' OnMousePressed (get) + +Property Let OnMousePressed(ByVal pvValue As Variant) + Call _PropertySet("OnMousePressed", pvValue) +End Property ' OnMousePressed (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' OnMouseReleased (get) + +Property Let OnMouseReleased(ByVal pvValue As Variant) + Call _PropertySet("OnMouseReleased", pvValue) +End Property ' OnMouseReleased (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name +' A group is determined by the successive TabIndexes of the radio button +' The name of the group = the name of its first element + + Utils._SetCalledSub("Dialog.OptionGroup") + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set OptionGroup = Nothing + If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function + +Dim iAllCount As Integer, iRadioLast As Integer, iGroupCount As Integer, iBegin As Integer, iEnd As Integer +Dim oRadios() As Object, sGroupName As String +Dim i As Integer, j As Integer, bFound As Boolean, ocControl As Object, oRadio As Object, iTabIndex As Integer +Dim ogGroup As Object, vGroup() As Variant, vIndex() As Variant + iAllCount = Controls.Count + If iAllCount > 0 Then + iRadioLast = -1 + ReDim oRadios(0 To iAllCount - 1) + For i = 0 To iAllCount - 1 ' Store all RadioButtons objects + Set ocControl = Controls(i) + If ocControl._SubType = CTLRADIOBUTTON Then + iRadioLast = iRadioLast + 1 + Set oRadios(iRadioLast) = ocControl + End If + Next i + Else + Goto Error_Arg ' No control in dialog + End If + + If iRadioLast < 0 then Goto Error_Arg ' No radio buttons in the dialog + + 'Resort oRadio array based on tab indexes + If iRadioLast > 0 Then + For i = 0 To iRadioLast - 1 ' Bubble sort + For j = i + 1 To iRadioLast + If oRadios(i).TabIndex > oRadios(j).TabIndex Then + Set oRadio = oRadios(i) + Set oRadios(i) = oRadios(j) + Set oRadios(j) = oRadio + End If + Next j + Next i + End If + + 'Scan Names to find match with argument + bFound = False + For i = 0 To iRadioLast + If UCase(oRadios(i)._Name) = UCase(pvGroupName) Then + Select Case i + Case 0 : bFound = True + Case Else + If oRadios(i).TabIndex > oRadios(i - 1).TabIndex + 1 Then + bFound = True + Else + Goto Error_Arg ' same group as preceding item although name correct + End If + End Select + If bFound Then + iBegin = i + iEnd = i + sGroupName = oRadios(i)._Name + End If + ElseIf bFound Then + If oRadios(i).TabIndex = oRadios(i - 1).TabIndex + 1 Then iEnd = i + End If + Next i + + If bFound Then ' Create OptionGroup + iGroupCount = iEnd - iBegin + 1 + Set ogGroup = New OptionGroup + ReDim vGroup(0 To iGroupCount - 1) + ReDim vIndex(0 To iGroupCount - 1) + With ogGroup + ._This = ogGroup + ._Name = sGroupName + ._Count = iGroupCount + ._ButtonsGroup = vGroup + ._ButtonsIndex = vIndex + For i = 0 To iGroupCount - 1 + Set ._ButtonsGroup(i) = oRadios(iBegin + i).ControlModel + ._ButtonsIndex(i) = i + Next i + ._ParentType = CTLPARENTISDIALOG + ._ParentComponent = UnoDialog + End With + Else Goto Error_Arg + End If + + Set OptionGroup = ogGroup + +Exit_Function: + Utils._ResetCalledSub("Dialog.OptionGroup") + Exit Function +Error_Arg: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.OptionGroup", Erl) + GoTo Exit_Function +End Function ' OptionGroup V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Page() As Variant + Page = _PropertyGet("Page") +End Property ' Page (get) + +Property Let Page(ByVal pvValue As Variant) + Call _PropertySet("Page", pvValue) +End Property ' Page (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _Parent +End Function ' Parent (get) V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Const cstThisSub = "Dialog.Properties" + Utils._SetCalledSub(cstThisSub) + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Width() As Variant + Width = _PropertyGet("Width") +End Property ' Width (get) + +Property Let Width(ByVal pvValue As Variant) + Call _PropertySet("Width", pvValue) +End Property ' Width (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.Controls") + +Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer + + Set ocControl = Nothing + If Not IsLoaded Then Goto Trace_Error_NotOpen + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISDIALOG + sParentShortcut = _Shortcut + sControls() = UnoDialog.Model.getElementNames() + iControlCount = UBound(sControls) + 1 + + If IsMissing(pvIndex) Then ' No argument, return Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + oCounter._Count = iControlCount + Set oCounter._Parent = _This + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + ocControl._Name = sControls(pvIndex) + Case vbString ' Check control name validity (non case sensitive) + bFound = False + sIndex = UCase(Utils._Trim(pvIndex)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sIndex Then + bFound = True + Exit For + End If + Next i + If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + End Select + + ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name) + Set ocControl.ControlModel = UnoDialog.Model.getByName(ocControl._Name) + Set ocControl.ControlView = UnoDialog.getControl(ocControl._Name) + ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() + ocControl._FormComponent = UnoDialog + + ocControl._Initialize() + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("Dialog.Controls") + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex)) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_NotOpen: + TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, , _Name) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex)) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub EndExecute(ByVal Optional pvReturn As Variant) +' Stop executing the dialog + +If _ErrorHandler() Then On Local Error Goto Error_Sub + Utils._SetCalledSub("Dialog.endExecute") + + If IsMissing(pvReturn) Then pvReturn = 0 + If Not Utils._CheckArgument(pvReturn, 1, Utils._AddNumeric(), , False) Then Goto Trace_Error + +Dim lExecute As Long + lExecute = CLng(pvReturn) + If IsNull(_Dialog) Then Goto Error_Execute + If IsNull(UnoDialog) Then Goto Error_Not_Started + Call UnoDialog.endDialog(lExecute) + +Exit_Sub: + Utils._ResetCalledSub("Dialog.endExecute") + Exit Sub +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array("1", Utils._CStr(pvReturn))) + Goto Exit_Sub +Error_Execute: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Sub +Error_Not_Started: + TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + Goto Exit_Sub +Error_Sub: + TraceError(TRACEABORT, Err, "Dialog.endExecute", Erl) + GoTo Exit_Sub +End Sub ' EndExecute + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Execute() As Long +' Execute dialog + +'If _ErrorHandler() Then On Local Error Goto Error_Function +'Seems smart not to trap errors: debugging of dialog events otherwise made very difficult ! + Utils._SetCalledSub("Dialog.Execute") + +Dim lExecute As Long + If IsNull(_Dialog) Then Goto Error_Execute + If IsNull(UnoDialog) Then Goto Error_Not_Started + lExecute = UnoDialog.execute() + + Select Case lExecute + Case 1 : Execute = dlgOK + Case 0 : Execute = dlgCancel + Case Else : Execute = lExecute + End Select + +Exit_Function: + Utils._ResetCalledSub("Dialog.Execute") + Exit Function +Error_Execute: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Not_Started: + TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Execute", Erl) + GoTo Exit_Function +End Function ' Execute + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Dialog.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Dialog.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move( ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute Move method + Utils._SetCalledSub("Dialog.Move") + On Local Error Goto Error_Function + Move = False +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("Move") : iArgNr = 1 + Case UCase("Dialog.Move") : iArgNr = 0 + End Select + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function + +Dim iArg As Integer, iWrong As Integer ' Check arguments values + iArg = 0 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If + If iArg > 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) + Goto Exit_Function + End If + +Dim iPosSize As Integer + iPosSize = 0 + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + If iPosSize > 0 Then UnoDialog.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) + Move = True + +Exit_Function: + Utils._ResetCalledSub("Dialog.Move") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Move", Erl) + GoTo Exit_Function +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("Dialog.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("Dialog.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Start() As Boolean +' Create dialog + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.Start") + +Dim oStart As Object + Start = False + If IsNull(_Dialog) Then Goto Error_Start + If Not IsNull(UnoDialog) Then Goto Error_Yet_Started + Set oStart = CreateUnoDialog(_Dialog) + If IsNull(oStart) Then + Goto Error_Start + Else + Start = True + Set UnoDialog = oStart + With _A2B_ + If .hasItem(COLLALLDIALOGS, _Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate + .Dialogs.Add(UnoDialog, UCase(_Name)) + End With + End If + +Exit_Function: + Utils._ResetCalledSub("Dialog.Start") + Exit Function +Error_Start: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Yet_Started: + TraceError(TRACEWARNING, ERRDIALOGSTARTED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Start", Erl) + GoTo Exit_Function +End Function ' Start + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Terminate() As Boolean +' Close dialog + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.Terminate") + + Terminate = False + If IsNull(_Dialog) Then Goto Error_Terminate + If IsNull(UnoDialog) Then Goto Error_Not_Started + UnoDialog.Dispose() + Set UnoDialog = Nothing + _A2B_.Dialogs.Remove(_Name) + Terminate = True + +Exit_Function: + Utils._ResetCalledSub("Dialog.Terminate") + Exit Function +Error_Terminate: + TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Not_Started: + TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog.Terminate", Erl) + GoTo Exit_Function +End Function ' Terminate + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + If IsLoaded Then + _PropertiesList = Array("Caption", "Height", "IsLoaded", "Name" _ + , "OnFocusGained", "OnFocusLost", "OnKeyPressed", "OnKeyReleased", "OnMouseDragged" _ + , "OnMouseEntered", "OnMouseExited", "OnMouseMoved", "OnMousePressed", "OnMouseReleased" _ + , "ObjectType", "Page", "Visible", "Width" _ + ) + Else + _PropertiesList = Array("IsLoaded", "Name" _ + ) + End If + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Dialog.get" & psProperty) + +Dim oDialogEvents As Object, sEventName As String + +'Execute + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("Name"), UCase("IsLoaded") + Case Else + If IsNull(UnoDialog) Then Goto Trace_Error_Dialog + End Select + Select Case UCase(psProperty) + Case UCase("Caption") + _PropertyGet = UnoDialog.getTitle() + Case UCase("Height") + _PropertyGet = UnoDialog.getPosSize().Height + Case UCase("IsLoaded") + _PropertyGet = _A2B_.hasItem(COLLALLDIALOGS, _Name) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased") + Set oDialogEvents = unoDialog.Model.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty) + If oDialogEvents.hasByName(sEventName) Then + _PropertyGet = oDialogEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case UCase("Page") + _PropertyGet = UnoDialog.Model.Step + Case UCase("Visible") + _PropertyGet = UnoDialog.IsVisible() + Case UCase("Width") + _PropertyGet = UnoDialog.getPosSize().Width + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Dialog.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Dialog: + TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("Dialog.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +Dim oDialogEvents As Object, sEventName As String, oEvent As Object, sListener As String, sEvent As String + +'Execute +Dim iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "Dialog.") Then iArgNr = 1 Else iArgNr = 2 + If IsNull(UnoDialog) Then Goto Trace_Error_Dialog + Select Case UCase(psProperty) + Case UCase("Caption") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + UnoDialog.setTitle(pvValue) + Case UCase("Height") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + UnoDialog.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT) + Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Not Utils._RegisterDialogEventScript(UnoDialog.Model _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + ) Then GoTo Trace_Error_Dialog + Case UCase("Page") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + UnoDialog.Model.Step = pvValue + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + UnoDialog.setVisible(pvValue) + Case UCase("Width") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value + UnoDialog.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Dialog.set" & psProperty) + Exit Function +Trace_Error_Dialog: + TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name) + _PropertySet = False + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Dialog._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba new file mode 100644 index 000000000..ded67fe59 --- /dev/null +++ b/wizards/source/access2base/DoCmd.xba @@ -0,0 +1,2662 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +Type _FindParams + FindRecord As Integer ' Set to 1 at first invocation of FindRecord + FindWhat As Variant + Match As Integer + MatchCase As Boolean + Search As Integer + SearchAsFormatted As Boolean ' Must be False + FindFirst As Boolean + OnlyCurrentField As Integer + Form As String ' Shortcut + GridControl As String ' Shortcut + Target As String ' Shortcut + LastRow As Long ' Last row explored - 0 = before first + LastColumn As Integer ' Last column explored - 0 ... N-1 index in next arrays; 0 if OnlyCurrentField = acCurrent + ColumnNames() As String ' Array of column names in grid with boundfield and of same type as FindWhat + ResultSetIndex() As Integer ' Array of column numbers in ResultSet +End Type + +Type _Window + Frame As Object ' com.sun.star.comp.framework.Frame + _Name As String ' Object Name + WindowType As Integer ' One of the object types + DocumentType As String ' Writer, Calc, ... - Only if WindowType = acDocument +End Type + +REM VBA allows call to actions with missing arguments e.g. OpenForm("aaa",,"[field]=2") +REM in StarBasic IsMissing requires Variant parameters + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ApplyFilter( _ + ByVal Optional pvFilter As Variant _ + , ByVal Optional pvSQL As Variant _ + , ByVal Optional pvControlName As Variant _ + ) As Boolean +' Set filter on open table, query, form or subform (if pvControlName present) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "ApplyFilter" + Utils._SetCalledSub(cstThisSub) + ApplyFilter = False + + If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments() + If IsMissing(pvFilter) Then pvFilter = "" + If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function + If IsMissing(pvSQL) Then pvSQL = "" + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function + If IsMissing(pvControlName) Then pvControlName = "" + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + +Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + If pvSQL <> "" _ + Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _ + Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter) + + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oTarget = _DatabaseForm(._Name, pvControlName) + Case acQuery, acTable + If pvControlName <> "" Then Goto Exit_Function + If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oTarget = .Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + + With oTarget + .Filter = sFilter + .ApplyFilter = True + .reload() + End With + ApplyFilter = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' ApplyFilter V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose(Optional ByVal pvObjectType As Variant _ + , Optional ByVal pvObjectName As Variant _ + , Optional ByVal pvSave As Variant _ + ) As Boolean + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Close" + Utils._SetCalledSub(cstThisSub) + mClose = False + If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments() + If IsMissing(pvSave) Then pvSave = acSavePrompt + If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acTable, acQuery, acForm, acReport)) _ + And Utils._CheckArgument(pvObjectName, 2, vbString) _ + And Utils._CheckArgument(pvSave, 3, Utils._AddNumeric(), Array(acSavePrompt)) _ + ) Then Goto Exit_Function + +Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object +Dim i As Integer, bFound As Boolean, lComponent As Long +Dim oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + ' Check existence of object and find its exact (case-sensitive) name + Select Case pvObjectType + Case acForm + sObjects = Application._GetAllHierarchicalNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.FORM + Case acTable + sObjects = oDatabase.Connection.getTables.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE + Case acQuery + sObjects = oDatabase.Connection.getQueries.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY + Case acReport + sObjects = oDatabase.Document.getReportDocuments.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT + End Select + bFound = False + For i = 0 To UBound(sObjects) + If UCase(pvObjectName) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + + Select Case pvObjectType + Case acForm + Set oController = oDatabase.Document.getFormDocuments.getByHierarchicalName(sObjectName) + mClose = oController.close() + Case acTable, acQuery ' Not optimal but it works !! + Set oController = oDatabase.Document.CurrentController + Set oObject = oController.loadComponent(lComponent, sObjectName, False) + oObject.frame.close(False) + mClose = True + Case acReport + Set oController = oDatabase.Document.getReportDocuments.getByName(sObjectName) + mClose = oController.close() + End Select + + +Exit_Function: + Set oObject = Nothing + Set oController = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Close", Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRCLOSEOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' (m)Close V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CopyObject(ByVal Optional pvSourceDatabase As Variant _ + , ByVal Optional pvNewName As Variant _ + , ByVal Optional pvSourceType As Variant _ + , ByVal Optional pvSourceName As Variant _ + ) As Boolean +' Copies tables and queries into identical (new) objects + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "CopyObject" + Utils._SetCalledSub(cstThisSub) + CopyObject = False + + If IsMissing(pvSourceDatabase) Then pvSourceDatabase = "" + If VarType(pvSourceDatabase) <> vbString Then + If Not Utils._CheckArgument(pvSourceDatabase, 1, OBJDATABASE) Then Goto Exit_Function + End If + If IsMissing(pvNewName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvSourceType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _ + ) Then Goto Exit_Function + If IsMissing(pvSourceName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto Exit_Function + +Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase As Object, bSameDatabase As Boolean +Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object, oTargetCol As Object, iRDBMS As Integer +Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object +Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant +Dim vNameComponents() As Variant, iNames As Integer, sSurround As String +Dim vInputField As Variant, vFieldBinary() As Variant, vOutputField As Variant +Dim oInput as Object, oOutput As Object, iNbFields As Integer, vValue As Variant +Dim vBinary As Variant, lInputSize As Long, lOutputSize As Long +Dim lInputRecs As Long, lInputMax As Long, vField As Variant, bProgressMeter As Boolean, sFile As String + +Const cstMaxBinlength = 2 * 65535 +Const cstChunkSize = 2 * 65535 +Const cstProgressMeterLimit = 100 + + Set oDatabase = Application._CurrentDb() + bSameDatabase = False + If VarType(pvSourceDatabase) = vbString Then + If pvSourceDatabase = "" Then + Set oSourceDatabase = oDatabase + bSameDatabase = True + Else + Set oSourceDatabase = Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), "", "", True) + If IsNull(oSourceDatabase) Then Goto Exit_Function + End If + Else + Set oSourceDatabase = pvSourceDatabase + End If + + With oDatabase + iRDBMS = ._RDBMS + If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Select Case pvSourceType + + Case acQuery + Set oSource = oSourceDatabase.QueryDefs(pvSourceName, True) + If IsNull(oSource) Then Goto Error_NotFound + Set oTarget = .QueryDefs(pvNewName, True) + If Not IsNull(oTarget) Then .Connection.getQueries.dropByName(oTarget.Name) ' a query with same name exists already ... drop it + If oSource.Query.EscapeProcessing Then + Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL) + Else + Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough) + End If + ' Save .odb document + .Document.store() + + Case acTable + Set oSource = oSourceDatabase.TableDefs(pvSourceName, True) + If IsNull(oSource) Then Goto Error_NotFound + Set oTarget = .TableDefs(pvNewName, True) + ' A table with same name exists already ... drop it + If Not IsNull(oTarget) Then .Connection.getTables.dropByName(oTarget.Name) + ' Copy source table columns + Set oSourceTable = oSource.Table + Set oTarget = .Connection.getTables.createDataDescriptor + oTarget.Description = oSourceTable.Description + vNameComponents = Split(pvNewName, ".") + iNames = UBound(vNameComponents) + If iNames >= 2 Then oTarget.CatalogName = vNameComponents(iNames - 2) Else oTarget.CatalogName = "" + If iNames >= 1 Then oTarget.SchemaName = vNameComponents(iNames - 1) Else oTarget.SchemaName = "" + oTarget.Name = vNameComponents(iNames) + oTarget.Type = oSourceTable.Type + Set oSourceColumns = oSourceTable.Columns + Set oTargetCol = oTarget.Columns.createDataDescriptor + For i = 0 To oSourceColumns.getCount() - 1 + ' Append each individual column to the table descriptor + Set oSourceCol = oSourceColumns.getByIndex(i) + _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase + oTarget.Columns.appendByDescriptor(oTargetCol) + Next i + + ' Copy keys + Set oSourceKeys = oSourceTable.Keys + Set oTargetKey = oTarget.Keys.createDataDescriptor() + For i = 0 To oSourceKeys.getCount() - 1 + ' Append each key to table descriptor + Set oSourceKey = oSourceKeys.getByIndex(i) + oTargetKey.DeleteRule = oSourceKey.DeleteRule + oTargetKey.Name = oSourceKey.Name + oTargetKey.ReferencedTable = oSourceKey.ReferencedTable + oTargetKey.Type = oSourceKey.Type + oTargetKey.UpdateRule = oSourceKey.UpdateRule + Set oTargetCol = oTargetKey.Columns.createDataDescriptor() + For j = 0 To oSourceKey.Columns.getCount() - 1 + Set oSourceCol = oSourceKey.Columns.getByIndex(j) + _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase, True + oTargetKey.Columns.appendByDescriptor(oTargetCol) + Next j + oTarget.Keys.appendByDescriptor(oTargetKey) + Next i + ' Duplicate table whole design + .Connection.getTables.appendByDescriptor(oTarget) + + ' Copy data + Select Case bSameDatabase + Case True + ' Build SQL statement to copy data + sSurround = Utils._Surround(oSource.Name) + sSql = "INSERT INTO " & Utils._Surround(pvNewName) & " SELECT " & sSurround & ".* FROM " & sSurround + DoCmd.RunSQL(sSql) + Case False + ' Copy data row by row and field by field + ' As it is slow ... display a progress meter + Set oInput = oSourceDatabase.OpenRecordset(oSource.Name, , , dbReadOnly) + Set oOutput = .Openrecordset(pvNewName) + + With oInput + If Not ( ._BOF And ._EOF ) Then + .MoveLast + lInputMax = .RecordCount + lInputRecs = 0 + .MoveFirst + bProgressMeter = ( lInputMax > cstProgressMeterLimit ) + + iNbFields = .Fields().Count - 1 + vFieldBinary = Array() + ReDim vFieldBinary(0 To iNbFields) + For i = 0 To iNbFields + vFieldBinary(i) = Utils._IsBinaryType(.Fields(i).Column.Type) + Next i + Else + bProgressMeter = False + End If + If bProgressMeter Then Application.SysCmd acSysCmdInitMeter, pvNewName & " 0 %", lInputMax + Do While Not .EOF() + oOutput.RowSet.moveToInsertRow() + oOutput._EditMode = dbEditAdd + For i = 0 To iNbFields + Set vInputField = .Fields(i) + Set vOutputField = oOutput.Fields(i) + If vFieldBinary(i) Then + lInputSize = vInputField.FieldSize + If lInputSize <= cstMaxBinlength Then + vField = Utils._getResultSetColumnValue(.RowSet, i + 1, True) + Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField) + ElseIf oDatabase._BinaryStream Then + ' Typically for SQLite where binary fields are limited + If lInputSize > vOutputField._Precision Then + TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1)) + Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, Null) + Else + sFile = Utils._GetRandomFileName("BINARY") + vInputField._WriteAll(sFile, "WriteAllBytes") + vOutputField._ReadAll(sFile, "ReadAllBytes") + Kill ConvertToUrl(sFile) + End If + End If + Else + vField = Utils._getResultSetColumnValue(.RowSet, i + 1) + If VarType(vField) = vbString Then + If Len(vField) > vOutputField._Precision Then + TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1)) + End If + End If + ' Update is done anyway, if too long, with truncation + Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField) + End If + Next i + + If oOutput.RowSet.IsNew And oOutput.RowSet.IsModified Then oOutput.RowSet.insertRow() + oOutput._EditMode = dbEditNone + lInputRecs = lInputRecs + 1 + If bProgressMeter Then + If lInputRecs Mod (lInputMax / 100) = 0 Then + Application.SysCmd acSysCmdUpdateMeter, pvNewName & " " & CStr(CLng(lInputRecs * 100 / lInputMax)) & "%", lInputRecs + End If + End If + .MoveNext + Loop + End With + + oOutput.mClose() + Set oOutput = Nothing + oInput.mClose() + Set oInput = Nothing + if bProgressMeter Then Application.SysCmd acSysCmdClearStatus + End Select + + Case Else + End Select + End With + + CopyObject = True + +Exit_Function: + ' Avoid closing the current database or the database object given as source argument + If VarType(pvSourceDatabase) = vbString And Not bSameDatabase Then + If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose() + End If + Set oSourceDatabase = Nothing + If Not IsNull(oOutput) Then oOutput.mClose() + Set oOutput = Nothing + If Not IsNull(oInput) Then oInput.mClose() + Set oInput = Nothing + Set oSourceCol = Nothing + Set oSourceKey = Nothing + Set oSourceKeys = Nothing + Set oSource = Nothing + Set oSourceTable = Nothing + Set oSourceColumns = Nothing + Set oTargetCol = Nothing + Set oTargetKey = Nothing + Set oTarget = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CopyObject V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function FindNext() As Boolean +' Must be called after a FindRecord +' Execute instructions set in FindRecord object + + If _ErrorHandler() Then On Local Error Goto Error_Function + FindNext = False + Utils._SetCalledSub("FindNext") + +Dim ofForm As Object, ocGrid As Object +Dim i As Integer, lInitialRow As Long, lFindRow As Long +Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean +Dim vFindValue As Variant, oFindrecord As Object + + Set oFindRecord = _A2B_.FindRecord + If IsNull(oFindRecord) Then GoTo Error_FindRecord + With oFindRecord + + If .FindRecord = 0 Then Goto Error_FindRecord + .FindRecord = 0 + Set ofForm = getObject(.Form) + If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola + Set ocGrid = getObject(.GridControl) + + ' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween + If ofForm.DatabaseForm.RowCount <= 0 then Goto Exit_Function ' Dataset is empty + + lInitialRow = .LastRow ' Used if Search = acSearchAll + + bFound = False + lFindRow = .LastRow + b2ndRound = False + Do + ' Last column ? Go to next row + If .LastColumn >= UBound(.ColumnNames) Then + bStop = False + If ofForm.DatabaseForm.isAfterLast() And .Search = acUp Then + ofForm.DatabaseForm.last() + ElseIf ofForm.DatabaseForm.isLast() And .Search = acSearchAll Then + ofForm.DatabaseForm.first() + b2ndRound = True + ElseIf ofForm.DatabaseForm.isBeforeFirst() And (.Search = acDown Or .Search = acSearchAll) Then + ofForm.DatabaseForm.first() + ElseIf ofForm.DatabaseForm.isFirst() And .search = acUp Then + ofForm.DatabaseForm.beforeFirst() + bStop = True + ElseIf ofForm.DatabaseForm.isLast() And .search = acDown Then + ofForm.DatabaseForm.afterLast() + bStop = True + ElseIf .Search = acUp Then + ofForm.DatabaseForm.previous() + Else + ofForm.DatabaseForm.next() + End If + lFindRow = ofForm.DatabaseForm.getRow() + If bStop Or (.Search = acSearchAll And lFindRow >= lInitialRow And b2ndRound) Then + ofForm.DatabaseForm.absolute(lInitialRow) + Exit Do + End If + .LastColumn = 0 + Else + .LastColumn = .LastColumn + 1 + End If + + ' Examine column contents + If .LastColumn <= UBound(.ColumnNames) Then + For i = .LastColumn To UBound(.ColumnNames) + vFindValue = Utils._getResultSetColumnValue(ofForm.DatabaseForm.createResultSet(), .ResultSetIndex(i)) + Select Case VarType(.FindWhat) + Case vbDate, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + bFound = ( .FindWhat = vFindValue ) + Case vbString + If VarType(vFindValue) = vbString Then + Select Case .Match + Case acStart + If .MatchCase Then + bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue ) + Else + bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) ) + End If + Case acAnyWhere + If .MatchCase Then + bFound = ( InStr(1, vFindValue, .FindWhat, 0) > 0 ) + Else + bFound = ( InStr(vFindValue, .FindWhat) > 0 ) + End If + Case acEntire + If .MatchCase Then + bFound = ( .FindWhat = vFindValue ) + Else + bFound = ( UCase(.FindWhat) = UCase(vFindValue) ) + End If + End Select + Else + bFound = False + End If + End Select + If bFound Then + .LastColumn = i + Exit For + End If + Next i + End If + Loop While Not bFound + + .LastRow = lFindRow + If bFound Then + ocGrid.Controls(.ColumnNames(.LastColumn)).setFocus() + .FindRecord = 1 + FindNext = True + End If + + End With + +Exit_Function: + Utils._ResetCalledSub("FindNext") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "FindNext", Erl) + GoTo Exit_Function +Error_FindRecord: + TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' FindNext V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function FindRecord(Optional ByVal pvFindWhat As Variant _ + , Optional ByVal pvMatch As Variant _ + , Optional ByVal pvMatchCase As Variant _ + , Optional ByVal pvSearch As Variant _ + , Optional ByVal pvSearchAsFormatted As Variant _ + , Optional ByVal pvTargetedField As Variant _ + , Optional ByVal pvFindFirst As Variant _ + ) As Boolean + +'Find a value (string or other) in the underlying data of a gridcontrol +'Search in all columns or only in one single control +' see pvTargetedField = acAll or acCurrent +' pvTargetedField may also be a shortcut to a GridControl or one of its subcontrols +'Initialize _Findrecord structure in Database root and call FindNext() to set cursor on found value + + If _ErrorHandler() Then On Local Error Goto Error_Function + FindRecord = False + + Utils._SetCalledSub("FindRecord") + If IsMissing(pvFindWhat) Or pvFindWhat = "" Then Call _TraceArguments() + If IsMissing(pvMatch) Then pvMatch = acEntire + If IsMissing(pvMatchCase) Then pvMatchCase = False + If IsMissing(pvSearch) Then pvSearch = acSearchAll + If IsMissing(pvSearchAsFormatted) Then pvSearchAsFormatted = False ' Anyway only False supported + If IsMissing(pvTargetedField) Then pvTargetedField = acCurrent + If IsMissing(pvFindFirst) Then pvFindFirst = True + If Not (Utils._CheckArgument(pvFindWhat, 1, Utils._AddNumeric(Array(vbString, vbDate))) _ + And Utils._CheckArgument(pvMatch, 2, Utils._AddNumeric(), Array(acAnywhere, acEntire, acStart)) _ + And Utils._CheckArgument(pvMatchCase, 3, vbBoolean) _ + And Utils._CheckArgument(pvSearch, 4, Utils._AddNumeric(), Array(acDown, acSearchAll, acUp)) _ + And Utils._CheckArgument(pvSearchAsFormatted, 5, vbBoolean, Array(False)) _ + And Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(vbString)) _ + And Utils._CheckArgument(pvFindFirst, 7, vbBoolean) _ + ) Then Exit Function + If VarType(pvTargetedField) <> vbString Then + If Not Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(), Array(acAll, acCurrent)) Then Exit Function + End If + +Dim ocTarget As Object, i As Integer, j As Integer, vNames() As Variant, iCount As Integer, vIndexes() As Variant +Dim vColumn As Variant, vDataField As Variant, ofParentForm As Variant, oColumns As Object, vParentGrid As Object +Dim bFound As Boolean, ocGridControl As Object, iFocus As Integer +Dim oFindRecord As _FindParams + With oFindRecord + .FindRecord = 0 + .FindWhat = pvFindWhat + .Match = pvMatch + .MatchCase = pvMatchCase + .Search = pvSearch + .SearchAsFormatted = pvSearchAsFormatted + .FindFirst = pvFindFirst + + ' Determine target + ' Either: pvTargetedField = Grid => search all fields + ' pvTargetedField = Control in Grid => search only in that column + ' pvTargetedField = acAll or acCurrent => determine focus + Select Case True + + Case VarType(pvTargetedField) = vbString + Set ocTarget = getObject(pvTargetedField) + + If ocTarget.SubType = CTLGRIDCONTROL Then + .OnlyCurrentField = acAll + .GridControl = ocTarget._Shortcut + .Target = .GridControl + ofParentForm = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name)) + If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + iCount = -1 + For i = 0 To ocTarget.ControlModel.Count - 1 + Set vColumn = ocTarget.ControlModel.getByIndex(i) + Set vDataField = vColumn.BoundField ' examine field type + If Not IsNull(vDataField) Then + If _CheckColumnType(pvFindWhat, vDataField) Then + iCount = iCount + 1 + ReDim Preserve vNames(0 To iCount) + vNames(iCount) = vColumn.Name + ReDim Preserve vIndexes(0 To iCount) + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(iCount) = j + 1 + Exit For + End If + Next j + End If + End If + Next i + + ElseIf ocTarget._Type = OBJCONTROL Then ' Control within a grid tbc + If IsNull(ocTarget.ControlModel.BoundField) Then Goto Error_Target ' Control MUST be bound to a database record or query + ' BoundField is in ControlModel, thanks PASTIM ! + .OnlyCurrentField = acCurrent + vParentGrid = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name)) + If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target + .GridControl = vParentGrid._Shortcut + ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name)) + If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola + If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm + .Target = ocTarget._Shortcut + Set vDataField = ocTarget.ControlModel.BoundField + If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target + ReDim vNames(0), vIndexes(0) + vNames(0) = ocTarget._Name + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(0) = j + 1 + Exit For + End If + Next j + End If + + Case Else ' Determine focus + iCount = Application.Forms()._Count + If iCount = 0 Then Goto Error_ActiveForm + bFound = False + For i = 0 To iCount - 1 ' Determine form having the focus + Set ofParentForm = Application.Forms(i) + If ofParentForm.Component.CurrentController.Frame.IsActive() Then + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Error_ActiveForm + If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm + iCount = ofParentForm.Controls().Count + bFound = False + For i = 0 To iCount - 1 + Set ocGridControl = ofParentForm.Controls(i) + If ocGridControl.SubType = CTLGRIDCONTROL Then + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Error_NoGrid + .GridControl= ocGridControl._Shortcut + iFocus = -1 + iFocus = ocGridControl.ControlView.getCurrentColumnPosition() ' Deprecated but no alternative found !! + + If pvTargetedField = acAll Or iFocus < 0 Or iFocus >= ocGridControl.ControlModel.Count Then ' Has a control within the grid the focus ? NO + .OnlyCurrentField = acAll + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + iCount = -1 + For i = 0 To ocGridControl.ControlModel.Count - 1 + Set vColumn = ocGridControl.ControlModel.getByIndex(i) + Set vDataField = vColumn.BoundField ' examine field type + If Not IsNull(vDataField) Then + If _CheckColumnType(pvFindWhat, vDataField) Then + iCount = iCount + 1 + ReDim Preserve vNames(0 To iCount) + vNames(iCount) = vColumn.Name + ReDim Preserve vIndexes(0 To iCount) + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(iCount) = j + 1 + Exit For + End If + Next j + End If + End If + Next i + + Else ' Has a control within the grid the focus ? YES + .OnlyCurrentField = acCurrent + Set vColumn = ocGridControl.ControlModel.getByIndex(iFocus) + Set ocTarget = ocGridControl.Controls(vColumn.Name) + .Target = ocTarget._Shortcut + Set vDataField = ocTarget.ControlModel.BoundField + If IsNull(vDataField) Then Goto Error_Target ' Control MUST be bound to a database record or query + If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target + ReDim vNames(0), vIndexes(0) + vNames(0) = ocTarget._Name + Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns + For j = 0 To oColumns.Count - 1 + If vDataField.Name = oColumns.ElementNames(j) Then + vIndexes(0) = j + 1 + Exit For + End If + Next j + End If + + End Select + + .Form = ofParentForm._Shortcut + .LastColumn = UBound(vNames) + .ColumnNames = vNames + .ResultSetIndex = vIndexes + If pvFindFirst Then + Select Case pvSearch + Case acDown, acSearchAll + ofParentForm.DatabaseForm.beforeFirst() + .LastRow = 0 + Case acUp + ofParentForm.DatabaseForm.afterLast() + .LastRow = ofParentForm.DatabaseForm.RowCount + 1 + End Select + Else + Select Case True + Case ofParentForm.DatabaseForm.isBeforeFirst And (pvSearch = acSearchAll Or pvSearch = acDown) + .LastRow = 0 + Case ofParentForm.DatabaseForm.isAfterLast And pvSearch = acUp + ofParentForm.DatabaseForm.last() ' RowCount produces a wrong value as long as last record has not been reached + .LastRow = ofParentForm.DatabaseForm.RowCount + 1 + Case Else + .LastRow = ofParentForm.DatabaseForm.getRow() + End Select + End If + + .FindRecord = 1 + + End With + Set _A2B_.FindRecord = oFindRecord + FindRecord = DoCmd.Findnext() + +Exit_Function: + Utils._ResetCalledSub("FindRecord") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "FindRecord", Erl) + GoTo Exit_Function +Error_ActiveForm: + TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0) + Goto Exit_Function +Error_DatabaseForm: + TraceError(TRACEFATAL, ERRDATABASEFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) + Goto Exit_Function +Error_Target: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(6, pvTargetedField)) + Goto Exit_Function +Error_NoGrid: + TraceError(TRACEFATAL, ERRNOGRIDINFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) + Goto Exit_Function +End Function ' FindRecord V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "GetHiddenAttribute" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible() + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' GetHiddenAttribute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GoToControl(Optional ByVal pvControlName As Variant) As Boolean +' Set the focus on the named control on the active form. +' Return False if the control does not exist or is disabled, + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("GoToControl") + If IsMissing(pvControlName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + + GoToControl = False +Dim oWindow As Object, ofForm As Object, ocControl As Object +Dim i As Integer, iCount As Integer + Set oWindow = _SelectWindow() + If oWindow.WindowType = acForm Then + Set ofForm = Application.Forms(oWindow._Name) + iCount = ofForm.Controls().Count + For i = 0 To iCount - 1 + ocControl = ofForm.Controls(i) + If UCase(ocControl._Name) = UCase(pvControlName) Then + If Methods.hasProperty(ocControl, "Enabled") Then + If ocControl.Enabled Then + ocControl.setFocus() + GoToControl = True + Exit For + End If + End If + End If + Next i + End If + +Exit_Function: + Utils._ResetCalledSub("GoToControl") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "GoToControl", Erl) + GoTo Exit_Function +End Function ' GoToControl V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GoToRecord(Optional ByVal pvObjectType As Variant _ + , Optional ByVal pvObjectName As Variant _ + , Optional ByVal pvRecord As Variant _ + , Optional ByVal pvOffset As Variant _ + ) As Boolean + +'Move to record indicated by pvRecord/pvOffset in the window designated by pvObjectType and pvObjectName + + If _ErrorHandler() Then On Local Error Goto Error_Function + GoToRecord = False + +Const cstThisSub = "GoTorecord" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvObjectName) Then pvObjectName = "" + If IsMissing(pvObjectType) Then pvObjectType = acActiveDataObject + If IsMissing(pvRecord) Then pvRecord = acNext + If IsMissing(pvOffset) Then pvOffset = 1 + If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _ + , Array(acActiveDataObject, acDataForm, acDataQuery, acDataTable)) _ + And Utils._CheckArgument(pvObjectName, 2, vbString) _ + And Utils._CheckArgument(pvRecord, 3, Utils._AddNumeric() _ + , Array(acFirst, acGoTo, acLast, acNewRec, acNext, acPrevious)) _ + And Utils._CheckArgument(pvOffset, 4, Utils._AddNumeric()) _ + ) Then Goto Exit_Function + If pvObjectType = acActiveDataObject And pvObjectName <> "" Then Goto Error_Target + If pvOffset < 0 And pvRecord <> acGoTo Then Goto Error_Offset + +Dim ofForm As Object, oGeneric As Object, oResultSet As Object, oWindow As Object +Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long +Dim sObjectName, iLengthName As Integer + Select Case pvObjectType + Case acActiveDataObject + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oResultSet = _DatabaseForm(._Name, "") + Case acQuery, acTable + If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oResultSet = .Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + Case acDataForm + ' pvObjectName can be "myForm", "Forms!myForm", "Forms!myForm!mySubform" or "Forms!myForm!mySubform.Form" + sObjectName = UCase(pvObjectName) + iLengthName = Len(sObjectName) + Select Case True + Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" And Right(sObjectName, 5) = ".FORM" + Set ofForm = getObject(pvObjectName) + If ofForm._Type <> OBJSUBFORM Then Goto Error_Target + Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" + Set oGeneric = getObject(pvObjectName) + If oGeneric._Type = OBJFORM Or oGeneric._Type = OBJSUBFORM Then + Set ofForm = oGeneric + ElseIf oGeneric.SubType = CTLSUBFORM Then + Set ofForm = oGeneric.Form + Else Goto Error_Target + End If + Case sObjectName = "" + Call _TraceArguments() + Case Else + Set ofForm = Application.Forms(pvObjectName) + End Select + Set oResultSet = ofForm.DatabaseForm + Case acDataQuery + Set oWindow = _SelectWindow(acQuery, pvObjectName) + If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor + Case acDataTable + Set oWindow = _SelectWindow(acTable, pvObjectName) + If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor + Case Else + End Select + + ' Check if current row updated => Save it + If oResultSet.IsNew Then + oResultSet.insertRow() + ElseIf oResultSet.IsModified Then + oResultSet.updateRow() + End If + + lOffset = pvOffset + Select Case pvRecord + Case acFirst : GoToRecord = oResultSet.first() + Case acGoTo : GoToRecord = oResultSet.absolute(lOffset) + Case acLast : GoToRecord = oResultSet.last() + Case acNewRec + oResultSet.last() ' To simulate the behaviour in the UI + oResultSet.moveToInsertRow() + GoToRecord = True + Case acNext + If lOffset = 1 Then + GoToRecord = oResultSet.next() + Else + GoToRecord = oResultSet.relative(lOffset) + End If + Case acPrevious + If lOffset = 1 Then + GoToRecord = oResultSet.previous() + Else + GoToRecord = oResultSet.relative(- lOffset) + End If + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_Target: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(2, pvObjectName)) + Goto Exit_Function +Error_Offset: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(4, pvOffset)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' GoToRecord + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Maximize() As Boolean +' Maximize the window having the focus + Utils._SetCalledSub("Maximize") + +Dim oWindow As Object + Maximize = False + Set oWindow = _SelectWindow() + If Not IsNull(oWindow.Frame) Then + If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMaximized") Then oWindow.Frame.ContainerWindow.IsMaximized = True ' Ignored when <= OO3.2 + Maximize = True + End If + + Utils._ResetCalledSub("Maximize") + Exit Function +End Function ' Maximize V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Minimize() As Boolean +' Maximize the form having the focus + Utils._SetCalledSub("Minimize") + +Dim oWindow As Object + Minimize = False + Set oWindow = _SelectWindow() + If Not IsNull(oWindow.Frame) Then + If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMinimized") Then oWindow.Frame.ContainerWindow.IsMinimized = True + Minimize = True + End If + + Utils._ResetCalledSub("Minimize") + Exit Function +End Function ' Minimize V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveSize(ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute MoveSize action + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("MoveSize") + MoveSize = False + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function + +Dim iArg As Integer, iWrong As Integer ' Check arguments values + iArg = 0 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If + If iArg > 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArg, iWrong)) + Goto Exit_Function + End If + +Dim iPosSize As Integer + iPosSize = 0 + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + +Dim oWindow As Object + Set oWindow = _SelectWindow() + With oWindow + If Not IsNull(.Frame) Then + If Utils._hasUNOProperty(.Frame.ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + .Frame.ContainerWindow.IsMaximized = False + .Frame.ContainerWindow.IsMinimized = False + End If + .Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) + MoveSize = True + End If + End With + +Exit_Function: + Utils._ResetCalledSub("MoveSize") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "MoveSize", Erl) + GoTo Exit_Function +End Function ' MoveSize V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenForm(Optional ByVal pvFormName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvFilterName As Variant _ + , Optional ByVal pvWhereCondition As Variant _ + , Optional ByVal pvDataMode As Variant _ + , Optional ByVal pvWindowMode As Variant _ + , Optional ByVal pvOpenArgs As Variant _ + ) As Variant + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenForm") + If IsMissing(pvFormName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acNormal + If IsMissing(pvFilterName) Then pvFilterName = "" + If IsMissing(pvWhereCondition) Then pvWhereCondition = "" + If IsMissing(pvDataMode) Then pvDataMode = acFormPropertySettings + If IsMissing(pvWindowMode) Then pvWindowMode = acWindowNormal + If IsMissing(pvOpenArgs) Then pvOpenArgs = "" + Set OpenForm = Nothing + If Not (Utils._CheckArgument(pvFormName, 1, vbString) _ + And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acNormal, acPreview, acDesign)) _ + And Utils._CheckArgument(pvFilterName, 3, vbString) _ + And Utils._CheckArgument(pvWhereCondition, 4, vbString) _ + And Utils._CheckArgument(pvDataMode, 5, Utils._AddNumeric(), Array(acFormAdd, acFormEdit, acFormPropertySettings, acFormReadOnly)) _ + And Utils._CheckArgument(pvWindowMode, 6, Utils._AddNumeric(), Array(acDialog, acHidden, acIcon, acWindowNormal)) _ + ) Then Goto Exit_Function + +Dim ofForm As Object, sWarning As String +Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object + + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + Set ofForm = Application.AllForms(pvFormName) + If ofForm.IsLoaded Then + sWarning = _GetLabel("ERR" & ERRFORMYETOPEN) + sWarning = Join(Split(sWarning, "%0"), ofForm._Name) + TraceLog(TRACEANY, "OpenForm: " & sWarning) + Set OpenForm = ofForm + Goto Exit_Function + End If +' Open the form + Select Case pvView + Case acNormal, acPreview: bOpenMode = False + Case acDesign : bOpenMode = True + End Select + Set oController = oDatabase.Document.CurrentController + Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode) + +' Apply the filters (FilterName) AND (WhereCondition) +Dim sFilter As String, oForm As Object, oFormsCollection As Object + If pvFilterName = "" And pvWhereCondition = "" Then + sFilter = "" + ElseIf pvFilterName = "" Or pvWhereCondition = "" Then + sFilter = pvFilterName & pvWhereCondition + Else + sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")" + End If + Set oFormsCollection = oOpenForm.DrawPage.Forms + If oFormsCollection.getCount() > 0 Then Set oForm = oFormsCollection.getByIndex(0) Else Set oForm = Nothing + If Not IsNull(oForm) Then + If sFilter <> "" Then + oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter) + oForm.ApplyFilter = True + oForm.reload() + ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed + oForm.Filter = "" + oForm.ApplyFilter = False + oForm.reload() + End If + End If + +'Housekeeping + Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open + With ofForm + If Not IsNull(.DatabaseForm) Then + Select Case pvDataMode + Case acFormAdd + .AllowAdditions = True + .AllowDeletions = False + .AllowEdits = False + Case acFormEdit + .AllowAdditions = True + .AllowDeletions = True + .AllowEdits = True + Case acFormReadOnly + .AllowAdditions = False + .AllowDeletions = False + .AllowEdits = False + Case acFormPropertySettings + End Select + End If + .Visible = ( pvWindowMode <> acHidden ) + ._OpenArgs = pvOpenArgs + 'To avoid AOO 3.4 bug See http://user.services.openoffice.org/en/forum/viewtopic.php?f=13&t=53751 + .Component.CurrentController.ViewSettings.ShowOnlineLayout = True + End With + + Set OpenForm = ofForm + +Exit_Function: + Utils._ResetCalledSub("OpenForm") + Set ofForm = Nothing + Set oOpenForm = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenForm", Erl) + Set OpenForm = Nothing + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1) + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName) + Set OpenForm = Nothing + Goto Exit_Function +End Function ' OpenForm V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenQuery(Optional ByVal pvQueryName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenQuery") + If IsMissing(pvQueryName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acViewNormal + If IsMissing(pvDataMode) Then pvDataMode = acEdit + OpenQuery = DoCmd._OpenObject("Query", pvQueryName, pvView, pvDataMode) + +Exit_Function: + Utils._ResetCalledSub("OpenQuery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenQuery", Erl) + GoTo Exit_Function +End Function ' OpenQuery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenReport(Optional ByVal pvReportName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenReport") + If IsMissing(pvReportName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acViewNormal + If IsMissing(pvDataMode) Then pvDataMode = acEdit + OpenReport = DoCmd._OpenObject("Report", pvReportName, pvView, pvDataMode) + +Exit_Function: + Utils._ResetCalledSub("OpenReport") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenReport", Erl) + GoTo Exit_Function +End Function ' OpenReport + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain a SELECT query +' pvOption can force pass through mode + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenSQL") + + OpenSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function + End If + + OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption) + +Exit_Function: + Utils._ResetCalledSub("OpenSQL") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenSQL", Erl) + GoTo Exit_Function +End Function ' OpenSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenTable(Optional ByVal pvTableName As Variant _ + , Optional ByVal pvView As Variant _ + , Optional ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("OpenTable") + If IsMissing(pvTableName) Then Call _TraceArguments() + If IsMissing(pvView) Then pvView = acViewNormal + If IsMissing(pvDataMode) Then pvDataMode = acEdit + OpenTable = DoCmd._OpenObject("Table", pvTableName, pvView, pvDataMode) + +Exit_Function: + Utils._ResetCalledSub("OpenTable") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenTable", Erl) + GoTo Exit_Function +End Function ' OpenTable + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OutputTo(ByVal pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvOutputFormat As Variant _ + , ByVal Optional pvOutputFile As Variant _ + , ByVal Optional pvAutoStart As Variant _ + , ByVal Optional pvTemplateFile As Variant _ + , ByVal Optional pvEncoding As Variant _ + , ByVal Optional pvQuality As Variant _ + ) As Boolean +REM https://wiki.openoffice.org/wiki/Framework/Article/Filter/FilterList_OOo_3_0 +REM https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options +REM https://msdn.microsoft.com/en-us/library/ms709353%28v=vs.85%29.aspx +'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms +' acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OutputTo" + Utils._SetCalledSub(cstThisSub) + + OutputTo = False + + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputForm)) Then Goto Exit_Function + If IsMissing(pvObjectName) Then pvObjectName = "" + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvOutputFormat) Then pvOutputFormat = "" + If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function + If pvOutputFormat <> "" Then + If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ + UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _ + , UCase(acFormatODS), UCase(acFormatXLS), UCase(acFormatXLSX), UCase(acFormatTXT) _ + , "PDF", "ODT", "DOC", "HTML", "ODS", "XLS", "XLSX", "TXT", "CSV", "" _ + )) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity + End If + If IsMissing(pvOutputFile) Then pvOutputFile = "" + If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function + If IsMissing(pvAutoStart) Then pvAutoStart = False + If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function + If IsMissing(pvTemplateFile) Then pvTemplateFile = "" + If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function + If IsMissing(pvEncoding) Then pvEncoding = 0 + If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function + If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint + If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function + + If pvObjectType = acOutputTable Or pvObjectType = acOutputQuery Then + OutputTo = Application._CurrentDb().OutputTo( _ + pvObjectType _ + , pvObjectName _ + , pvOutputFormat _ + , pvOutputFile _ + , pvAutoStart _ + , pvTemplateFile _ + , pvEncoding _ + , pvQuality _ + ) + GoTo Exit_Function + End If + +Dim vWindow As Variant, sOutputFile As String, ofForm As Object, i As Integer, bFound As Boolean + 'Find applicable form + If pvObjectName = "" Then + vWindow = _SelectWindow() + If vWindow.WindowType <> acOutoutForm Then Goto Error_Action + Set ofForm = Application.Forms(vWindow._Name) + Else + bFound = False + For i = 0 To Application.Forms()._Count - 1 + Set ofForm = Application.Forms(i) + If UCase(ofForm._Name) = UCase(pvObjectName) Then + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Error_NotFound + End If + + 'Determine format and parameters +Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport As Object, sSuffix As String + If pvOutputFormat = "" Then + sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format + If sOutputFormat = "" Then Goto Exit_Function + Else + sOutputFormat = UCase(pvOutputFormat) + End If + Select Case sOutputFormat + Case UCase(acFormatPDF), "PDF" + sFilter = acFormatPDF + oFilterData = Array( _ + _MakePropertyValue ("ExportFormFields", False), _ + ) + sSuffix = "pdf" + Case UCase(acFormatDOC), "DOC" + sFilter = acFormatDOC + oFilterData = Array() + sSuffix = "doc" + Case UCase(acFormatODT), "ODT" + sFilter = acFormatODT + oFilterData = Array() + sSuffix = "odt" + Case UCase(acFormatHTML), "HTML" + sFilter = acFormatHTML + oFilterData = Array() + sSuffix = "html" + End Select + oExport = Array( _ + _MakePropertyValue("Overwrite", True), _ + _MakePropertyValue("FilterName", sFilter), _ + _MakePropertyValue("FilterData", oFilterData), _ + ) + + 'Determine output file + If pvOutputFile = "" Then ' Prompt file picker to user + sOutputFile = _PromptFilePicker(sSuffix) + If sOutputFile = "" Then Goto Exit_Function + Else + sOutputFile = pvOutputFile + End If + sOutputFile = ConvertToURL(sOutputFile) + + 'Create file + On Local Error Goto Error_File + ofForm.Component.storeToURL(sOutputFile, oExport) + On Local Error Goto Error_Function + + 'Launch application, if requested + If pvAutoStart Then Call _ShellExecute(sOutputFile) + + OutputTo = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Action: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_File: + TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile) + GoTo Exit_Function +End Function ' OutputTo V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Quit(Optional ByVal pvSave As Variant) As Variant +' Quit the application +' Modified from Andrew Pitonyak's Base Macro Programming §5.8.1 + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Quit" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvSave) Then pvSave = acQuitSaveAll + If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _ + Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _ + ) Then Goto Exit_Function + +Dim oDatabase As Object, oDoc As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If Not IsNull(oDatabase) Then + Set oDoc = oDatabase.Document + Select Case pvSave + Case acQuitPrompt + If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function + Case acQuitSaveNone + oDoc.setModified(False) + Case Else + End Select + If HasUnoInterfaces(oDoc, "com.sun.star.util.XCloseable") Then + If (oDoc.isModified) Then + If (oDoc.hasLocation AND (Not oDoc.isReadOnly)) Then + oDoc.store() + End If + End If + oDoc.close(true) + Else + oDoc.dispose() + End If + End If + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Set oDatabase = Nothing + Set oDoc = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + Set OpenForm = Nothing + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' Quit V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub RunApp(Optional ByVal pvCommandLine As Variant) +' Convert to URL and execute the Command Line + + If _ErrorHandler() Then On Local Error Goto Error_Sub + + Utils._SetCalledSub("RunApp") + + If IsMissing(pvCommandLine) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub + + _ShellExecute(ConvertToURL(pvCommandLine)) + +Exit_Sub: + Utils._ResetCalledSub("RunApp") + Exit Sub +Error_Sub: + TraceError(TRACEABORT, Err, "RunApp", Erl) + GoTo Exit_Sub +End Sub ' RunApp V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RunCommand(Optional pvCommand As Variant, Optional pbReturnCommand As Boolean) As Variant +' Execute command via DispatchHelper +' pbReturnCommand = internal parameter to only return the exact command string (always absent if uno prefix present in pvCommand) + + If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort +Const cstThisSub = "RunCommand" + Utils._SetCalledSub(cstThisSub) + +Dim iVBACommand As Integer, sOOCommand As String, sDispatch As String + If IsMissing(pvCommand) Then Call _TraceArguments() + If Not ( Utils._CheckArgument(pvCommand, 1, Utils._AddNumeric(vbString)) ) Then Goto Exit_Function + If IsMissing(pbReturnCommand) Then pbReturnCommand = False + + RunCommand = True + +Const cstUnoPrefix = ".uno:" + If VarType(pvCommand) = vbString Then + sOOCommand = pvCommand + iVBACommand = -1 + If _IsLeft(sOOCommand, cstUnoPrefix) Then + Call _DispatchCommand(sOOCommand) + Goto Exit_Function + End If + Else + sOOCommand = "" + iVBACommand = pvCommand + End If + + Select Case True + Case iVBACommand = acCmdAboutMicrosoftAccess Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" + Case iVBACommand = acCmdAboutOpenOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" + Case iVBACommand = acCmdAboutLibreOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" + Case UCase(sOOCommand) = "ACTIVEHELP" : sDispatch = "ActiveHelp" + Case UCase(sOOCommand) = "ADDDIRECT" : sDispatch = "AddDirect" + Case UCase(sOOCommand) = "ADDFIELD" : sDispatch = "AddField" + Case UCase(sOOCommand) = "AUTOCONTROLFOCUS" : sDispatch = "AutoControlFocus" + Case UCase(sOOCommand) = "AUTOFILTER" : sDispatch = "AutoFilter" + Case UCase(sOOCommand) = "AUTOPILOTADDRESSDATASOURCE" : sDispatch = "AutoPilotAddressDataSource" + Case UCase(sOOCommand) = "BASICBREAK" : sDispatch = "BasicBreak" + Case iVBACommand = acCmdVisualBasicEditor Or UCase(sOOCommand) = "BASICIDEAPPEAR" : sDispatch = "BasicIDEAppear" + Case UCase(sOOCommand) = "BASICSTOP" : sDispatch = "BasicStop" + Case iVBACommand = acCmdBringToFront Or UCase(sOOCommand) = "BRINGTOFRONT" : sDispatch = "BringToFront" + Case UCase(sOOCommand) = "CHECKBOX" : sDispatch = "CheckBox" + Case UCase(sOOCommand) = "CHOOSEMACRO" : sDispatch = "ChooseMacro" + Case iVBACommand = acCmdClose Or UCase(sOOCommand) = "CLOSEDOC" : sDispatch = "CloseDoc" + Case UCase(sOOCommand) = "CLOSEWIN" : sDispatch = "CloseWin" + Case iVBACommand = acCmdToolbarsCustomize Or UCase(sOOCommand) = "CONFIGUREDIALOG" : sDispatch = "ConfigureDialog" + Case UCase(sOOCommand) = "CONTROLPROPERTIES" : sDispatch = "ControlProperties" + Case iVBACommand = acCmdChangeToCommandButton Or UCase(sOOCommand) = "CONVERTTOBUTTON" : sDispatch = "ConvertToButton" + Case iVBACommand = acCmdChangeToCheckBox Or UCase(sOOCommand) = "CONVERTTOCHECKBOX" : sDispatch = "ConvertToCheckBox" + Case iVBACommand = acCmdChangeToComboBox Or UCase(sOOCommand) = "CONVERTTOCOMBO" : sDispatch = "ConvertToCombo" + Case UCase(sOOCommand) = "CONVERTTOCURRENCY" : sDispatch = "ConvertToCurrency" + Case UCase(sOOCommand) = "CONVERTTODATE" : sDispatch = "ConvertToDate" + Case iVBACommand = acCmdChangeToTextBox Or UCase(sOOCommand) = "CONVERTTOEDIT" : sDispatch = "ConvertToEdit" + Case UCase(sOOCommand) = "CONVERTTOFILECONTROL" : sDispatch = "ConvertToFileControl" + Case iVBACommand = acCmdChangeToLabel Or UCase(sOOCommand) = "CONVERTTOFIXED" : sDispatch = "ConvertToFixed" + Case UCase(sOOCommand) = "CONVERTTOFORMATTED" : sDispatch = "ConvertToFormatted" + Case UCase(sOOCommand) = "CONVERTTOGROUP" : sDispatch = "ConvertToGroup" + Case UCase(sOOCommand) = "CONVERTTOIMAGEBTN" : sDispatch = "ConvertToImageBtn" + Case iVBACommand = acCmdChangeToImage Or UCase(sOOCommand) = "CONVERTTOIMAGECONTROL" : sDispatch = "ConvertToImageControl" + Case iVBACommand = acCmdChangeToListBox Or UCase(sOOCommand) = "CONVERTTOLIST" : sDispatch = "ConvertToList" + Case UCase(sOOCommand) = "CONVERTTONAVIGATIONBAR" : sDispatch = "ConvertToNavigationBar" + Case UCase(sOOCommand) = "CONVERTTONUMERIC" : sDispatch = "ConvertToNumeric" + Case UCase(sOOCommand) = "CONVERTTOPATTERN" : sDispatch = "ConvertToPattern" + Case iVBACommand = acCmdChangeToOptionButton Or UCase(sOOCommand) = "CONVERTTORADIO" : sDispatch = "ConvertToRadio" + Case UCase(sOOCommand) = "CONVERTTOSCROLLBAR" : sDispatch = "ConvertToScrollBar" + Case UCase(sOOCommand) = "CONVERTTOSPINBUTTON" : sDispatch = "ConvertToSpinButton" + Case UCase(sOOCommand) = "CONVERTTOTIME" : sDispatch = "ConvertToTime" + Case iVBACommand = acCmdCopy Or UCase(sOOCommand) = "COPY" : sDispatch = "Copy" + Case UCase(sOOCommand) = "CURRENCYFIELD" : sDispatch = "CurrencyField" + Case iVBACommand = acCmdCut Or UCase(sOOCommand) = "CUT" : sDispatch = "Cut" + Case UCase(sOOCommand) = "DATEFIELD" : sDispatch = "DateField" + Case iVBACommand = acCmdCreateRelationship Or UCase(sOOCommand) = "DBADDRELATION " : sDispatch = "DBAddRelation " + Case UCase(sOOCommand) = "DBCONVERTTOVIEW " : sDispatch = "DBConvertToView " + Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DBDELETE " : sDispatch = "DBDelete " + Case UCase(sOOCommand) = "DBDIRECTSQL " : sDispatch = "DBDirectSQL " + Case UCase(sOOCommand) = "DBDSADVANCEDSETTINGS " : sDispatch = "DBDSAdvancedSettings " + Case UCase(sOOCommand) = "DBDSCONNECTIONTYPE " : sDispatch = "DBDSConnectionType " + Case iVBACommand = acCmdDatabaseProperties Or UCase(sOOCommand) = "DBDSPROPERTIES " : sDispatch = "DBDSProperties " + Case UCase(sOOCommand) = "DBEDIT " : sDispatch = "DBEdit " + Case iVBACommand = acCmdSQLView Or UCase(sOOCommand) = "DBEDITSQLVIEW " : sDispatch = "DBEditSqlView " + Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBFORMDELETE " : sDispatch = "DBFormDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBFORMEDIT " : sDispatch = "DBFormEdit " + Case iVBACommand = acCmdFormView Or UCase(sOOCommand) = "DBFORMOPEN " : sDispatch = "DBFormOpen " + Case UCase(sOOCommand) = "DBFORMRENAME " : sDispatch = "DBFormRename " + Case iVBACommand = acCmdNewObjectForm Or UCase(sOOCommand) = "DBNEWFORM " : sDispatch = "DBNewForm " + Case UCase(sOOCommand) = "DBNEWFORMAUTOPILOT " : sDispatch = "DBNewFormAutoPilot " + Case UCase(sOOCommand) = "DBNEWQUERY " : sDispatch = "DBNewQuery " + Case UCase(sOOCommand) = "DBNEWQUERYAUTOPILOT " : sDispatch = "DBNewQueryAutoPilot " + Case UCase(sOOCommand) = "DBNEWQUERYSQL " : sDispatch = "DBNewQuerySql " + Case UCase(sOOCommand) = "DBNEWREPORT " : sDispatch = "DBNewReport " + Case UCase(sOOCommand) = "DBNEWREPORTAUTOPILOT " : sDispatch = "DBNewReportAutoPilot " + Case iVBACommand = acCmdNewObjectTable Or UCase(sOOCommand) = "DBNEWTABLE " : sDispatch = "DBNewTable " + Case UCase(sOOCommand) = "DBNEWTABLEAUTOPILOT " : sDispatch = "DBNewTableAutoPilot " + Case iVBACommand = acCmdNewObjectView Or UCase(sOOCommand) = "DBNEWVIEW " : sDispatch = "DBNewView " + Case UCase(sOOCommand) = "DBNEWVIEWSQL " : sDispatch = "DBNewViewSQL " + Case iVBACommand = acCmdOpenDatabase Or UCase(sOOCommand) = "DBOPEN " : sDispatch = "DBOpen " + Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBQUERYDELETE " : sDispatch = "DBQueryDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBQUERYEDIT " : sDispatch = "DBQueryEdit " + Case iVBACommand = acCmdNewObjectQuery Or UCase(sOOCommand) = "DBQUERYOPEN " : sDispatch = "DBQueryOpen " + Case UCase(sOOCommand) = "DBQUERYRENAME " : sDispatch = "DBQueryRename " + Case UCase(sOOCommand) = "DBREFRESHTABLES " : sDispatch = "DBRefreshTables " + Case iVBACommand = acCmdShowAllRelationships Or UCase(sOOCommand) = "DBRELATIONDESIGN " : sDispatch = "DBRelationDesign " + Case UCase(sOOCommand) = "DBRENAME " : sDispatch = "DBRename " + Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBREPORTDELETE " : sDispatch = "DBReportDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBREPORTEDIT " : sDispatch = "DBReportEdit " + Case iVBACommand = acCmdNewObjectReport Or UCase(sOOCommand) = "DBREPORTOPEN " : sDispatch = "DBReportOpen " + Case UCase(sOOCommand) = "DBREPORTRENAME " : sDispatch = "DBReportRename " + Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "DBSELECTALL " : sDispatch = "DBSelectAll " + Case UCase(sOOCommand) = "DBSHOWDOCINFOPREVIEW " : sDispatch = "DBShowDocInfoPreview " + Case UCase(sOOCommand) = "DBSHOWDOCPREVIEW " : sDispatch = "DBShowDocPreview " + Case iVBACommand = acCmdRemoveTable Or UCase(sOOCommand) = "DBTABLEDELETE " : sDispatch = "DBTableDelete " + Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBTABLEEDIT " : sDispatch = "DBTableEdit " + Case UCase(sOOCommand) = "DBTABLEFILTER " : sDispatch = "DBTableFilter " + Case iVBACommand = acCmdOpenTable Or UCase(sOOCommand) = "DBTABLEOPEN " : sDispatch = "DBTableOpen " + Case iVBACommand = acCmdRename Or UCase(sOOCommand) = "DBTABLERENAME " : sDispatch = "DBTableRename " + Case UCase(sOOCommand) = "DBUSERADMIN " : sDispatch = "DBUserAdmin " + Case UCase(sOOCommand) = "DBVIEWFORMS " : sDispatch = "DBViewForms " + Case UCase(sOOCommand) = "DBVIEWQUERIES " : sDispatch = "DBViewQueries " + Case UCase(sOOCommand) = "DBVIEWREPORTS " : sDispatch = "DBViewReports " + Case UCase(sOOCommand) = "DBVIEWTABLES " : sDispatch = "DBViewTables " + Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DELETE" : sDispatch = "Delete" + Case iVBACommand = acCmdDeleteRecord Or UCase(sOOCommand) = "DELETERECORD" : sDispatch = "DeleteRecord" + Case UCase(sOOCommand) = "DESIGNERDIALOG" : sDispatch = "DesignerDialog" + Case UCase(sOOCommand) = "EDIT" : sDispatch = "Edit" + Case UCase(sOOCommand) = "FIRSTRECORD" : sDispatch = "FirstRecord" + Case UCase(sOOCommand) = "FONTDIALOG" : sDispatch = "FontDialog" + Case UCase(sOOCommand) = "FONTHEIGHT" : sDispatch = "FontHeight" + Case UCase(sOOCommand) = "FORMATTEDFIELD" : sDispatch = "FormattedField" + Case UCase(sOOCommand) = "FORMFILTER" : sDispatch = "FormFilter" + Case iVBACommand = acCmdApplyFilterSort Or UCase(sOOCommand) = "FORMFILTERED" : sDispatch = "FormFiltered" + Case UCase(sOOCommand) = "FORMFILTEREXECUTE" : sDispatch = "FormFilterExecute" + Case UCase(sOOCommand) = "FORMFILTEREXIT" : sDispatch = "FormFilterExit" + Case UCase(sOOCommand) = "FORMFILTERNAVIGATOR" : sDispatch = "FormFilterNavigator" + Case UCase(sOOCommand) = "FORMPROPERTIES" : sDispatch = "FormProperties" + Case UCase(sOOCommand) = "FULLSCREEN" : sDispatch = "FullScreen" + Case UCase(sOOCommand) = "GALLERY" : sDispatch = "Gallery" + Case UCase(sOOCommand) = "GRID" : sDispatch = "Grid" + Case iVBACommand = acCmdSnapToGrid Or UCase(sOOCommand) = "GRIDUSE" : sDispatch = "GridUse" + Case iVBACommand = acCmdViewGrid Or UCase(sOOCommand) = "GRIDVISIBLE" : sDispatch = "GridVisible" + Case UCase(sOOCommand) = "GROUPBOX" : sDispatch = "GroupBox" + Case UCase(sOOCommand) = "HELPINDEX" : sDispatch = "HelpIndex" + Case UCase(sOOCommand) = "HELPSUPPORT" : sDispatch = "HelpSupport" + Case iVBACommand = acCmdInsertHyperlink Or UCase(sOOCommand) = "HYPERLINKDIALOG" : sDispatch = "HyperlinkDialog" + Case UCase(sOOCommand) = "IMAGEBUTTON" : sDispatch = "Imagebutton" + Case UCase(sOOCommand) = "IMAGECONTROL" : sDispatch = "ImageControl" + Case UCase(sOOCommand) = "LABEL" : sDispatch = "Label" + Case iVBACommand = acCmdMaximumRecords Or UCase(sOOCommand) = "LASTRECORD" : sDispatch = "LastRecord" + Case UCase(sOOCommand) = "LISTBOX" : sDispatch = "ListBox" + Case UCase(sOOCommand) = "MACRODIALOG" : sDispatch = "MacroDialog" + Case UCase(sOOCommand) = "MACROORGANIZER" : sDispatch = "MacroOrganizer" + Case UCase(sOOCommand) = "NAVIGATIONBAR" : sDispatch = "NavigationBar" + Case iVBACommand = acCmdObjectBrowser Or UCase(sOOCommand) = "NAVIGATOR" : sDispatch = "Navigator" + Case UCase(sOOCommand) = "NEWDOC" : sDispatch = "NewDoc" + Case UCase(sOOCommand) = "NEWRECORD" : sDispatch = "NewRecord" + Case UCase(sOOCommand) = "NEXTRECORD" : sDispatch = "NextRecord" + Case UCase(sOOCommand) = "NUMERICFIELD" : sDispatch = "NumericField" + Case UCase(sOOCommand) = "OPEN" : sDispatch = "Open" + Case UCase(sOOCommand) = "OPTIONSTREEDIALOG" : sDispatch = "OptionsTreeDialog" + Case UCase(sOOCommand) = "ORGANIZER" : sDispatch = "Organizer" + Case UCase(sOOCommand) = "PARAGRAPHDIALOG" : sDispatch = "ParagraphDialog" + Case iVBACommand = acCmdPaste Or UCase(sOOCommand) = "PASTE" : sDispatch = "Paste" + Case iVBACommand = acCmdPasteSpecial Or UCase(sOOCommand) = "PASTESPECIAL " : sDispatch = "PasteSpecial " + Case UCase(sOOCommand) = "PATTERNFIELD" : sDispatch = "PatternField" + Case UCase(sOOCommand) = "PREVRECORD" : sDispatch = "PrevRecord" + Case iVBACommand = acCmdPrint Or UCase(sOOCommand) = "PRINT" : sDispatch = "Print" + Case UCase(sOOCommand) = "PRINTDEFAULT" : sDispatch = "PrintDefault" + Case UCase(sOOCommand) = "PRINTERSETUP" : sDispatch = "PrinterSetup" + Case iVBACommand = acCmdPrintPreview Or UCase(sOOCommand) = "PRINTPREVIEW" : sDispatch = "PrintPreview" + Case UCase(sOOCommand) = "PUSHBUTTON" : sDispatch = "Pushbutton" + Case UCase(sOOCommand) = "QUIT" : sDispatch = "Quit" + Case UCase(sOOCommand) = "RADIOBUTTON" : sDispatch = "RadioButton" + Case iVBACommand = acCmdSaveRecord Or UCase(sOOCommand) = "RECSAVE" : sDispatch = "RecSave" + Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "RECSEARCH" : sDispatch = "RecSearch" + Case iVBACommand = acCmdUndo Or UCase(sOOCommand) = "RECUNDO" : sDispatch = "RecUndo" + Case iVBACommand = acCmdRefresh Or UCase(sOOCommand) = "REFRESH" : sDispatch = "Refresh" + Case UCase(sOOCommand) = "RELOAD" : sDispatch = "Reload" + Case iVBACommand = acCmdRemoveFilterSort Or UCase(sOOCommand) = "REMOVEFILTERSORT" : sDispatch = "RemoveFilterSort" + Case iVBACommand = acCmdRunMacro Or UCase(sOOCommand) = "RUNMACRO" : sDispatch = "RunMacro" + Case iVBACommand = acCmdSave Or UCase(sOOCommand) = "SAVE" : sDispatch = "Save" + Case UCase(sOOCommand) = "SAVEALL" : sDispatch = "SaveAll" + Case iVBACommand = acCmdSaveAs Or UCase(sOOCommand) = "SAVEAS" : sDispatch = "SaveAs" + Case UCase(sOOCommand) = "SAVEBASICAS" : sDispatch = "SaveBasicAs" + Case UCase(sOOCommand) = "SCRIPTORGANIZER" : sDispatch = "ScriptOrganizer" + Case UCase(sOOCommand) = "SCROLLBAR" : sDispatch = "ScrollBar" + Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "SEARCHDIALOG" : sDispatch = "SearchDialog" + Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll" + Case iVBACommand = acCmdSelectAllRecords Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll" + Case iVBACommand = acCmdSendToBack Or UCase(sOOCommand) = "SENDTOBACK" : sDispatch = "SendToBack" + Case UCase(sOOCommand) = "SHOWFMEXPLORER" : sDispatch = "ShowFmExplorer" + Case UCase(sOOCommand) = "SIDEBAR" : sDispatch = "Sidebar" + Case iVBACommand = acCmdSortDescending Or UCase(sOOCommand) = "SORTDOWN" : sDispatch = "SortDown" + Case iVBACommand = acCmdSortAscending Or UCase(sOOCommand) = "SORTUP" : sDispatch = "Sortup" + Case UCase(sOOCommand) = "SPINBUTTON" : sDispatch = "SpinButton" + Case UCase(sOOCommand) = "STATUSBARVISIBLE" : sDispatch = "StatusBarVisible" + Case UCase(sOOCommand) = "SWITCHCONTROLDESIGNMODE" : sDispatch = "SwitchControlDesignMode" + Case iVBACommand = acCmdTabOrder Or UCase(sOOCommand) = "TABDIALOG" : sDispatch = "TabDialog" + Case UCase(sOOCommand) = "USEWIZARDS" : sDispatch = "UseWizards" + Case UCase(sOOCommand) = "VERSIONDIALOG" : sDispatch = "VersionDialog" + Case UCase(sOOCommand) = "VIEWDATASOURCEBROWSER" : sDispatch = "ViewDataSourceBrowser" + Case iVBACommand = acCmdDatasheetView Or UCase(sOOCommand) = "VIEWFORMASGRID" : sDispatch = "ViewFormAsGrid" + Case iVBACommand = acCmdZoomSelection Or UCase(sOOCommand) = "ZOOM" : sDispatch = "Zoom" + Case Else + If iVBACommand >= 0 Then Goto Exit_Function + sDispatch = pvCommand + End Select + + If pbReturnCommand Then RunCommand = cstUnoPrefix & sDispatch Else Call _DispatchCommand(cstUnoPrefix & sDispatch) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' RunCommand V0.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RunSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain an ACTION query + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("RunSQL") + + RunSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + + RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption) + +Exit_Function: + Utils._ResetCalledSub("RunSQL") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "RunSQL", Erl) + GoTo Exit_Function +End Function ' RunSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SelectObject( ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvInDatabaseWindow As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SelectObject" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + If Not IsMissing(pvInDatabaseWindow) Then + If Not Utils._CheckArgument(pvInDatabaseWindow, 3, vbBoolean, False) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + With oWindow.Frame.ContainerWindow + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .setEnable(True) ' Added to try to bypass desynchro issue in Linux + .toFront() ' Added to force window change in Linux + End With + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SelectObject V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SendObject(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvOutputFormat As Variant _ + , ByVal Optional pvTo As Variant _ + , ByVal Optional pvCc As Variant _ + , ByVal Optional pvBcc As Variant _ + , ByVal Optional pvSubject As Variant _ + , ByVal Optional pvMessageText As Variant _ + , ByVal Optional pvEditMessage As Variant _ + , ByVal Optional pvTemplateFile As Variant _ + ) As Boolean +'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms +'To be prepared: acFormatCSV and acFormatODS for tables/queries ? + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("SendObject") + SendObject = False + + If IsMissing(pvObjectType) Then pvObjectType = acSendNoObject + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acSendNoObject, acSendForm)) Then Goto Exit_Function + If IsMissing(pvObjectName) Then pvObjectName = "" + If Not Utils._CheckArgument(pvObjectName, 2,vbString) Then Goto Exit_Function + If IsMissing(pvOutputFormat) Then pvOutputFormat = "" + If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function + If pvOutputFormat <> "" Then + If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ + UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _ + , "PDF", "ODT", "DOC", "HTML", "" _ + )) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity + End If + If IsMissing(pvTo) Then pvTo = "" + If Not Utils._CheckArgument(pvTo, 4, vbString) Then Goto Exit_Function + If IsMissing(pvCc) Then pvCc = "" + If Not Utils._CheckArgument(pvCc, 5, vbString) Then Goto Exit_Function + If IsMissing(pvBcc) Then pvBcc = "" + If Not Utils._CheckArgument(pvBcc, 6, vbString) Then Goto Exit_Function + If IsMissing(pvSubject) Then pvSubject = "" + If Not Utils._CheckArgument(pvSubject, 7, vbString) Then Goto Exit_Function + If IsMissing(pvMessageText) Then pvMessageText = "" + If Not Utils._CheckArgument(pvMessageText, 8, vbString) Then Goto Exit_Function + If IsMissing(pvEditMessage) Then pvEditMessage = True + If Not Utils._CheckArgument(pvEditMessage, 9, vbBoolean) Then Goto Exit_Function + If IsMissing(pvTemplateFile) Then pvTemplateFile = "" + If Not Utils._CheckArgument(pvTemplateFile, 10, vbString, "") Then Goto Exit_Function + +Dim vTo() As Variant, vCc() As Variant, vBcc() As Variant, oWindow As Object +Dim sDirectory As String, sOutputFile As String, sSuffix As String, sOutputFormat As String +Const cstSemiColon = ";" + If pvTo <> "" Then vTo() = Split(pvTo, cstSemiColon) Else vTo() = Array() + If pvCc <> "" Then vCc() = Split(pvCc, cstSemiColon) Else vCc() = Array() + If pvBcc <> "" Then vBcc() = Split(pvBcc, cstSemiColon) Else vBcc() = Array() + Select Case True + Case pvObjectType = acSendNoObject And pvObjectName = "" + SendObject = _SendWithoutAttachment(vTo, vCc, vBcc, pvSubject, pvMessageText) + Case Else + If pvObjectType = acSendNoObject And pvObjectName <> "" Then + If Not FileExists(pvObjectName) Then Goto Error_File + sOutputFile = pvObjectName + Else ' OutputFile has to be created + If pvObjectType <> acSendNoObject And pvObjectName = "" Then + oWindow = _SelectWindow() + If oWindow.WindowType <> acSendForm Then Goto Error_Action + pvObjectType = acSendForm + pvObjectName = oWindow._Name + End If + sDirectory = Utils._getTempDirectoryURL() + If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/" + If pvOutputFormat = "" Then + sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format + If sOutputFormat = "" Then Goto Exit_Function + Else + sOutputFormat = UCase(pvOutputFormat) + End If + Select Case sOutputFormat + Case UCase(acFormatPDF), "PDF" : sSuffix = "pdf" + Case UCase(acFormatDOC), "DOC" : sSuffix = "doc" + Case UCase(acFormatODT), "ODT" : sSuffix = "odt" + Case UCase(acFormatHTML), "HTML" : sSuffix = "html" + End Select + sOutputFile = sDirectory & pvObjectName & "." & sSuffix + If Not OutputTo(pvObjectType, pvObjectName, sOutputFormat, sOutputFile, False) Then Goto Exit_Function + End If + SendObject = _SendWithAttachment(vTo, vCc, vBcc, pvSubject, Array(sOutputFile), pvMessageText, pvEditMessage) + End Select + +Exit_Function: + Utils._ResetCalledSub("SendObject") + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SendObject", Erl) + GoTo Exit_Function +Error_Action: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) + Goto Exit_Function +Error_File: + TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , pvObjectName) + Goto Exit_Function +End Function ' SendObject V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvHidden As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + SetHiddenAttribute = False +Const cstThisSub = "SetHiddenAttribute" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + If IsMissing(pvHidden) Then + pvHidden = True + Else + If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + oWindow.Frame.ContainerWindow.setVisible(Not pvHidden) + SetHiddenAttribute = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SetHiddenAttribute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetOrderBy( _ + ByVal Optional pvOrder As Variant _ + , ByVal Optional pvControlName As Variant _ + ) As Boolean +' Sort ann open table, query, form or subform (if pvControlName present) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SetOrderBy" + Utils._SetCalledSub(cstThisSub) + SetOrderBy = False + + If IsMissing(pvOrder) Then pvOrder = "" + If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function + If IsMissing(pvControlName) Then pvControlName = "" + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + +Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + sOrder = oDatabase._ReplaceSquareBrackets(pvOrder) + + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oTarget = _DatabaseForm(._Name, pvControlName) + Case acQuery, acTable + If pvControlName <> "" Then Goto Exit_Function + If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable + ' FormOperations returns <Null> in OpenOffice + Set oTarget = .Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + + With oTarget + .Order = sOrder + .reload() + End With + SetOrderBy = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SetOrderBy V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ShowAllrecords() As Boolean +' Removes any existing filter that exists on the current table, query or form + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "ShowAllRecords" + Utils._SetCalledSub(cstThisSub) + ShowAllRecords = False + +Dim oWindow As Object, oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + Set oWindow = _SelectWindow() + Select Case oWindow.WindowType + Case acForm, acQuery, acTable + RunCommand(acCmdRemoveFilterSort) + ShowAllrecords = True + Case Else ' Ignore action + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' ShowAllrecords V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _CheckColumnType(pvFindWhat As Variant, vDataField As Variant) As Boolean +' Return true if both arguments of the same type +' vDataField is a ResultSet column + +Dim bFound As Boolean + bFound = False + With com.sun.star.sdbc.DataType + Select Case vDataField.Type + Case .DATE, .TIME, .TIMESTAMP + If VarType(pvFindWhat) = vbDate Then bFound = True + Case .TINYINT, .SMALLINT, .INTEGER, .BIGINT, .FLOAT, .REAL, .DOUBLE, .NUMERIC, .DECIMAL + If Utils._InList(VarType(pvFindWhat), Utils._AddNumeric()) Then bFound = True + Case .CHAR, .VARCHAR, .LONGVARCHAR + If VarType(pvFindWhat) = vbString Then bFound = True + Case Else + End Select + End With + + _CheckColumnType = bFound + +End Function ' _CheckColumnType V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Sub _ConvertDataDescriptor( ByRef poSource As Object _ + , ByVal piSourceRDBMS As Integer _ + , ByRef poTarget As Object _ + , ByRef poDatabase As Object _ + , ByVal Optional pbKey As Boolean _ + ) +' Convert source column descriptor to target descriptor +' If RDMSs identical, simply move property by property +' Otherwise +' - Use Type conversion tables (cfr. DataTypes By RDBMS.ods case study) +' - Select among synonyms the entry with the lowest Precision at least >= source Precision +' - Derive TypeName and Precision values + +Dim vTypesReference() As Variant, vTypes() As Variant, vTypeNames() As Variant +Dim i As Integer, iType As Integer, iTypeAlias As Integer +Dim iNbTypes As Integer, iBestFit As Integer, lFitPrecision As Long, lPrecision As Long + + On Local Error Goto Error_Sub + If IsMissing(pbKey) Then pbKey = False + + poTarget.Name = poSource.Name + poTarget.Description = poSource.Description + If Not pbKey Then + poTarget.ControlDefault = poSource.ControlDefault + poTarget.FormatKey = poSource.FormatKey + poTarget.HelpText = poSource.HelpText + poTarget.Hidden = poSource.Hidden + End If + poTarget.IsCurrency = poSource.IsCurrency + poTarget.IsNullable = poSource.IsNullable + poTarget.Scale = poSource.Scale + + If piSourceRDBMS = poDatabase._RDBMS Or poDatabase._RDBMS = DBMS_UNKNOWN Then + poTarget.Type = poSource.Type + poTarget.Precision = poSource.Precision + poTarget.TypeName = poSource.TypeName + Goto Exit_Sub + End If + + ' Search DataType compatibility + With poDatabase + ' Find source datatype entry in Reference array + iType = -1 + For i = 0 To UBound(._ColumnTypesReference) + If ._ColumnTypesReference(i) = poSource.Type Then + iType = i + Exit For + End If + Next i + If iType = -1 Then Goto Error_Compatibility + iTypeAlias = ._ColumnTypesAlias(iType) + ' Find best choice for the datatype of the target column + iNbTypes = UBound(._ColumnTypes) + iBestFit = -1 + lFitPrecision = -2 ' Some POSTGRES datatypes have a precision of -1 + For i = 0 To iNbTypes + If ._ColumnTypes(i) = iTypeAlias Then ' Minimal fit = correct datatype + lPrecision = ._ColumnPrecisions(i) + If iBestFit = -1 _ + Or (iBestFit > -1 And poSource.Precision > 0 And lPrecision >= poSource.Precision And lPrecision < lFitPrecision) _ + Or (iBestFit > -1 And poSource.Precision = 0 And lPrecision > lFitPrecision) Then ' First fit or better fit + iBestFit = i + lFitPrecision = lPrecision + End If + End If + Next i + If iBestFit = -1 Then Goto Error_Compatibility + poTarget.Type = iTypeAlias + poTarget.Precision = lFitPrecision + poTarget.TypeName = ._ColumnTypeNames(iBestFit) + End With + +Exit_Sub: + Exit Sub +Error_Compatibility: + TraceError(TRACEFATAL, ERRCOMPATIBILITY, Utils._CalledSub(), 0, 1, poSource.Name) + Goto Exit_Sub +Error_Sub: + TraceError(TRACEABORT, Err, "_ConvertDataDescriptor", Erl) + Goto Exit_Sub +End Sub ' ConvertDataDescriptor V1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DatabaseForm(psForm As String, psControl As String) +'Return DatabaseForm element of Form object (based on psForm which is known as a real form name) +'or of SubForm object (based on psControl which is checked for being a subform) + +Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer +Dim bFound As Boolean, i As Integer, sName As String + + Set oForm = Application.Forms(psForm) + If psControl <> "" Then ' Search subform + With oForm.DatabaseForm + iControlCount = .getCount() + bFound = False + If iControlCount > 0 Then + sControls() = .getElementNames() + sName = UCase(Utils._Trim(psControl)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sName Then + bFound = True + Exit For + End If + Next i + End If + End With + If bFound Then sName = sControls(i) Else Goto Trace_NotFound + Set oControl = oForm.Controls(sName) + If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound + Set _DatabaseForm = oControl.Form.DatabaseForm + Else + Set _DatabaseForm = oForm.DatabaseForm + End If + +Exit_Function: + Exit Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) + Goto Exit_Function +Trace_SubFormNotFound: + TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) + Goto Exit_Function +End Function ' _DatabaseForm V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _DispatchCommand(ByVal psCommand As String) +' Execute command given as argument - ".uno:" is presumed already present +Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String +Dim oResult As Variant +Dim sCommand As String + + Set oDocument = _SelectWindow().Frame + Set oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper") + sTargetFrameName = "" + oResult = oDispatcher.executeDispatch(oDocument, psCommand, sTargetFrameName, 0, oArgs()) + +End Sub ' _DispatchCommand V1.3.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal psLastComponent As String) As String +' Return "Forms!myForm" from "Forms!myForm!datField" and "datField" + + If Len(psShortcut) > Len(psLastComponent) Then + _getUpperShortcut = Split(psShortcut, "!" & Utils._Surround(psLastComponent))(0) + Else + _getUpperShortcut = psShortcut + End If + +End Function ' _getUpperShortcut + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _OpenObject(ByVal psObjectType As String _ + , ByVal pvObjectName As Variant _ + , ByVal pvView As Variant _ + , ByVal pvDataMode As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + + _OpenObject = False + If Not (Utils._CheckArgument(pvObjectName, 1, vbString) _ + And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _ + And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _ + ) Then Goto Exit_Function +Dim oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + +Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object +Dim i As Integer, bFound As Boolean, lComponent As Long, oQuery As Object + + ' Check existence of object and find its exact (case-sensitive) name + Select Case psObjectType + Case "Table" + sObjects = oDatabase.Connection.getTables.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE + Case "Query" + sObjects = oDatabase.Connection.getQueries.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY + Case "Report" + sObjects = oDatabase.Document.getReportDocuments.ElementNames() + lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT + End Select + bFound = False + For i = 0 To UBound(sObjects) + If UCase(pvObjectName) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + bFound = True + Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + + If psObjectType = "Query" Then ' Processing for action query + Set oQuery = Application._CurrentDb().QueryDefs(pvObjectName) + If oQuery.pType <> dbQSelect Then + _OpenObject = oQuery.Execute() + GoTo Exit_Function + End If + End If + Set oController = oDatabase.Document.CurrentController + Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign )) + _OpenObject = True + +Exit_Function: + Set oObject = Nothing + Set oQuery = Nothing + Set oController = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenObject", Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) + Goto Exit_Function +End Function ' _OpenObject V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PromptFormat(ByVal pvList As Variant) As String +' Return user selection in Format dialog + +Dim oDialog As Object, iOKCancel As Integer, oControl As Object + + Set oDialog = CreateUnoDialog(Utils._GetDialogLib().dlgFormat) + oDialog.Title = _GetLabel("DLGFORMAT_TITLE") + + Set oControl = oDialog.Model.getByName("lblFormat") + oControl.Label = _GetLabel("DLGFORMAT_LBLFORMAT_LABEL") + oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP") + + Set oControl = oDialog.Model.getByName("cboFormat") + oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP") + + Set oControl = oDialog.Model.getByName("cmdOK") + oControl.Label = _GetLabel("DLGFORMAT_CMDOK_LABEL") + oControl.HelpText = _GetLabel("DLGFORMAT_CMDOK_HELP") + + Set oControl = oDialog.Model.getByName("cmdCancel") + oControl.Label = _GetLabel("DLGFORMAT_CMDCANCEL_LABEL") + oControl.HelpText = _GetLabel("DLGFORMAT_CMDCANCEL_HELP") + + Set oControl = oDialog.Model.getByName("cboFormat") + If UBound(pvList) >= 0 Then + oControl.Text = pvList(0) + oControl.StringItemList = pvList + Else + oControl.Text = "" + oControl.StringItemList = Array() + End If + + iOKCancel = oDialog.Execute() + Select Case iOKCancel + Case 1 ' OK + _PromptFormat = oControl.Text + Case 0 ' Cancel + _PromptFormat = "" + Case Else + End Select + oDialog.Dispose() + +End Function ' _PromptFormat V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional ByVal psWindow As String) As Object +' No argument: find active window +' 2 arguments: find corresponding window +' Return a _Window object type describing the found window + +Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer +Dim bFound As Boolean, bActive As Boolean, sName As String, iType As Integer, sDocumentType As String +Dim sImplementation As String, vLocation() As Variant +Dim oWindow As _Window +Dim vPersistent As Variant, oForm As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + + bActive = IsMissing(piWindowType) + If IsMissing(psWindow) Then psWindow = "" + Set oWindow.Frame = Nothing + oWindow.DocumentType = "" + If bActive Then + oWindow.WindowType = acDefault + oWindow._Name = "" + Else + oWindow.WindowType = piWindowType + Select Case piWindowType + Case acBasicIDE, acDatabaseWindow : oWindow._Name = "" + Case Else : oWindow._Name = psWindow + End Select + End If + iType = acDefault + sDocumentType = "" + + Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") + Set oEnum = oDesk.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = "" + Select Case sImplementation + Case "com.sun.star.comp.basic.BasicIDE" + Set oFrame = oComp.CurrentController.Frame + iType = acBasicIDE + sName = "" + Case "com.sun.star.comp.dba.ODatabaseDocument" + Set oFrame = oComp.CurrentController.Frame + iType = acDatabaseWindow + sName = "" + Case "SwXTextDocument" + If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then + Select Case oComp.Identifier + Case "com.sun.star.sdb.FormDesign" ' Form + iType = acForm + Case "com.sun.star.sdb.TextReportDesign" ' Report + iType = acReport + Case "com.sun.star.text.TextDocument" ' Writer + vLocation = Split(oComp.getLocation(), "/") + If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = "" + iType = acDocument + sDocumentType = docWriter + End Select + If iType = acForm Then ' Identify persistent Form name + vPersistent = Split(oComp.StringValue, "/") + sName = _GetHierarchicalName(vPersistent(UBound(vPersistent) - 1)) + ElseIf iType = acReport Then ' Identify Report name + For i = 0 To UBound(oComp.Args()) + If oComp.Args(i).Name = "DocumentTitle" Then + sName = oComp.Args(i).Value + Exit For + End If + Next i + End If + Set oFrame = oComp.CurrentController.Frame + End If + Case "org.openoffice.comp.dbu.ODatasourceBrowser" + Set oFrame = oComp.Frame + If Not IsEmpty(oComp.Selection) Then ' Empty for (F4) DatasourceBrowser !! + For i = 0 To UBound(oComp.Selection()) + If oComp.Selection(i).Name = "Command" Then + sName = oComp.Selection(i).Value + ElseIf oComp.Selection(i).Name = "CommandType" Then + Select Case oComp.selection(i).Value + Case com.sun.star.sdb.CommandType.TABLE + iType = acTable + Case com.sun.star.sdb.CommandType.QUERY + iType = acQuery + Case com.sun.star.sdb.CommandType.COMMAND + iType = acQuery ' SQL for future use ? + End Select + End If + Next i + ' Else ignore + End If + Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode + If Not bActive Then + If UCase(Right(oComp.Title, Len(psWindow))) = UCase(psWindow) Then ' No rigorous mean found to identify Name + Set oFrame = oComp.Frame + Select Case sImplementation + Case "org.openoffice.comp.dbu.OTableDesign" : iType = acTable + Case "org.openoffice.comp.dbu.OQueryDesign" : iType = acQuery + End Select + sName = Right(oComp.Title, Len(psWindow)) + End If + Else + Set oFrame = Nothing + End If + Case "org.openoffice.comp.dbu.ORelationDesign" + Set oFrame = oComp.Frame + iType = acDiagram + sName = "" + Case "com.sun.star.comp.sfx2.BackingComp" ' Welcome screen + Set oFrame = oComp.Frame + iType = acWelcome + sName = "" + Case Else ' Other Calc, ..., whatever documents + If Utils._hasUNOProperty(oComp, "Location") Then + vLocation = Split(oComp.getLocation(), "/") + If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = "" + iType = acDocument + If Utils._hasUNOProperty(oComp, "Identifier") Then + Select Case oComp.Identifier + Case "com.sun.star.sheet.SpreadsheetDocument" : sDocumentType = docCalc + Case "com.sun.star.presentation.PresentationDocument" : sDocumentType = docImpress + Case "com.sun.star.drawing.DrawingDocument" : sDocumentType = docDraw + Case "com.sun.star.formula.FormulaProperties" : sDocumentType = docMath + Case Else : sDocumentType = "" + End Select + End If + Set oFrame = oComp.CurrentController.Frame + End If + End Select + If bActive And Not IsNull(oFrame) Then + If oFrame.ContainerWindow.IsActive() Then + bFound = True + Exit Do + End If + ElseIf iType = piWindowType And UCase(sName) = UCase(psWindow) Then + bFound = True + Exit Do + End If + Loop + + If bFound Then + Set oWindow.Frame = oFrame + oWindow._Name = sName + oWindow.WindowType = iType + oWindow.DocumentType = sDocumentType + Else + Set oWindow.Frame = Nothing + End If + +Exit_Function: + Set _SelectWindow = oWindow + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SelectWindow", Erl) + GoTo Exit_Function +End Function ' _SelectWindow V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _SendWithAttachment( _ + ByVal pvRecipients() As Variant _ + , ByVal pvCcRecipients() As Variant _ + , ByVal pvBccRecipients() As Variant _ + , ByVal psSubject As String _ + , ByVal pvAttachments() As Variant _ + , ByVal pvBody As String _ + , ByVal pbEditMessage As Boolean _ + ) As Boolean + +' Send message with attachments + If _ErrorHandler() Then On Local Error Goto Error_Function + _SendWithAttachment = False + +Const cstWindows = 1 +Const cstLinux = 4 +Const cstSemiColon = ";" +Dim oServiceMail as Object, oMail As Object, oMessage As Object, vFlag As Variant +Dim vCc() As Variant, i As Integer, iOS As Integer, sProduct As String, bMailProvider As Boolean + + 'OPENOFFICE <= 3.6 and LIBREOFFICE have XSimple...Mail interface while OPENOFFICE >= 4.0 has XSystemMailProvider interface + sProduct = UCase(Utils._GetProductName()) + bMailProvider = ( Left(sProduct, 4) = "OPEN" And Left(_GetProductName("VERSION"), 3) >= "4.0" ) + + iOS = GetGuiType() + Select Case iOS + Case cstLinux + oServiceMail = createUnoService("com.sun.star.system.SimpleCommandMail") + Case cstWindows + If bMailProvider Then oServiceMail = createUnoService("com.sun.star.system.SystemMailProvider") _ + Else oServiceMail = createUnoService("com.sun.star.system.SimpleSystemMail") + Case Else + Goto Error_Mail + End Select + + If bMailProvider Then Set oMail = oServiceMail.queryMailClient() _ + Else Set oMail = oServiceMail.querySimpleMailClient() + If IsNull(oMail) Then Goto Error_Mail + + 'Reattribute Recipients >= 2nd to ccRecipients + If UBound(pvRecipients) <= 0 Then + If UBound(pvCcRecipients) >= 0 Then vCc = pvCcRecipients + Else + ReDim vCc(0 To UBound(pvRecipients) - 1 + UBound(pvCcRecipients) + 1) + For i = 0 To UBound(pvRecipients) - 1 + vCc(i) = pvRecipients(i + 1) + Next i + For i = UBound(pvRecipients) To UBound(vCc) + vCc(i) = pvCcRecipients(i - UBound(pvRecipients)) + Next i + End If + + If bMailProvider Then + Set oMessage = oMail.createMailMessage() + If UBound(pvRecipients) >= 0 Then oMessage.Recipient = pvRecipients(0) + If psSubject <> "" Then oMessage.Subject = psSubject + Select Case iOS ' Not published differences between com.sun.star.system.SimpleCommandMail and SimpleSystemMail + Case cstLinux + If UBound(vCc) >= 0 Then oMessage.CcRecipient = Array(Join(vCc, cstSemiColon)) + If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = Array(Join(pvBccRecipients, cstSemiColon)) + Case cstWindows + If UBound(vCc) >= 0 Then oMessage.CcRecipient = vCc + If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = pvBccRecipients + End Select + If UBound(pvAttachments) >= 0 Then oMessage.Attachement = pvAttachments + If pvBody <> "" Then oMessage.Body = pvBody + If pbEditMessage Then + vFlag = com.sun.star.system.MailClientFlags.DEFAULTS + Else + vFlag = com.sun.star.system.MailClientFlags.NO_USER_INTERFACE + End If + oMail.sendMailMessage(oMessage, vFlag) + Else + Set oMessage = oMail.createSimpleMailMessage() ' Body NOT SUPPORTED ! + If UBound(pvRecipients) >= 0 Then oMessage.setRecipient(pvRecipients(0)) + If psSubject <> "" Then oMessage.setSubject(psSubject) + Select Case iOS + Case cstLinux + If UBound(vCc) >= 0 Then oMessage.setCcRecipient(Array(Join(vCc, cstSemiColon))) + If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(Array(Join(pvBccRecipients, cstSemiColon))) + Case cstWindows + If UBound(vCc) >= 0 Then oMessage.setCcRecipient(vCc) + If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(pvBccRecipients) + End Select + If UBound(pvAttachments) >= 0 Then oMessage.setAttachement(pvAttachments) + If pbEditMessage Then + vFlag = com.sun.star.system.SimpleMailClientFlags.DEFAULTS + Else + vFlag = com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE + End If + oMail.sendSimpleMailMessage(oMessage, vFlag) + End If + + _SendWithAttachment = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "_SendWithAttachment", Erl) + Goto Exit_Function +Error_Mail: + TraceError(TRACEFATAL, ERRSENDMAIL, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' _SendWithAttachment V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _SendWithoutAttachment(ByVal pvTo As Variant _ + , ByVal pvCc As Variant _ + , ByVal pvBcc As Variant _ + , ByVal psSubject As String _ + , ByVal psBody As String _ + ) As Boolean +'Send simple message with mailto: syntax +Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object +Const cstComma = "," + + If _ErrorHandler() Then On Local Error Goto Error_Function + + If UBound(pvTo) >= 0 Then sTo = Trim(Join(pvTo, cstComma)) Else sTo = "" + If UBound(pvCc) >= 0 Then sCc = Trim(Join(pvCc, cstComma)) Else sCc = "" + If UBound(pvBcc) >= 0 Then sBcc = Trim(Join(pvBcc, cstComma)) Else sBcc = "" + + sMailTo = "mailto:" _ + & sTo & "?" _ + & Iif(sCc = "", "", "cc=" & sCc & "&") _ + & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _ + & Iif(psSubject = "", "", "subject=" & psSubject & "&") _ + & Iif(psBody = "", "", "body=" & psBody & "&") + If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1) + sMailTo = ConvertToUrl(sMailTo) + + oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper") + oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array()) + + _SendWithoutAttachment = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "_SendWithoutAttachments", Erl) + _SendWithoutAttachment = False + Goto Exit_Function +End Function ' _SendWithoutAttachment V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _ShellExecute(sCommand As String) +' Execute shell command + +Dim oShell As Object + Set oShell = createUnoService("com.sun.star.system.SystemShellExecute") + oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.URIS_ONLY) + +End Sub ' _ShellExecute V0.8.5 + + \ No newline at end of file diff --git a/wizards/source/access2base/Event.xba b/wizards/source/access2base/Event.xba new file mode 100644 index 000000000..eb5f23019 --- /dev/null +++ b/wizards/source/access2base/Event.xba @@ -0,0 +1,493 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be EVENT +Private _EventSource As Object +Private _EventType As String +Private _EventName As String +Private _SubComponentName As String +Private _SubComponentType As Long +Private _ContextShortcut As String +Private _ButtonLeft As Boolean ' com.sun.star.awt.MouseButton.XXX +Private _ButtonRight As Boolean +Private _ButtonMiddle As Boolean +Private _XPos As Variant ' Null or Long +Private _YPos As Variant ' Null or Long +Private _ClickCount As Long +Private _KeyCode As Integer ' com.sun.star.awt.Key.XXX +Private _KeyChar As String +Private _KeyFunction As Integer ' com.sun.star.awt.KeyFunction.XXX +Private _KeyAlt As Boolean +Private _KeyCtrl As Boolean +Private _KeyShift As Boolean +Private _FocusChangeTemporary As Boolean ' False if user action in same window +Private _RowChangeAction As Long ' com.sun.star.sdb.RowChangeAction.XXX +Private _Recommendation As String ' "IGNORE" or "" + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJEVENT + _EventSource = Nothing + _EventType = "" + _EventName = "" + _SubComponentName = "" + _SubComponentType = -1 + _ContextShortcut = "" + _ButtonLeft = False ' See com.sun.star.awt.MouseButton.XXX + _ButtonRight = False + _ButtonMiddle = False + _XPos = Null + _YPos = Null + _ClickCount = 0 + _KeyCode = 0 + _KeyChar = "" + _KeyFunction = com.sun.star.awt.KeyFunction.DONTKNOW + _KeyAlt = False + _KeyCtrl = False + _KeyShift = False + _FocusChangeTemporary = False + _RowChangeAction = 0 + _Recommendation = "" +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ButtonLeft() As Variant + ButtonLeft = _PropertyGet("ButtonLeft") +End Property ' ButtonLeft (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ButtonMiddle() As Variant + ButtonMiddle = _PropertyGet("ButtonMiddle") +End Property ' ButtonMiddle (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ButtonRight() As Variant + ButtonRight = _PropertyGet("ButtonRight") +End Property ' ButtonRight (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ClickCount() As Variant + ClickCount = _PropertyGet("ClickCount") +End Property ' ClickCount (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ContextShortcut() As Variant + ContextShortcut = _PropertyGet("ContextShortcut") +End Property ' ContextShortcut (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EventName() As Variant + EventName = _PropertyGet("EventName") +End Property ' EventName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EventSource() As Variant + EventSource = _PropertyGet("EventSource") +End Property ' EventSource (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EventType() As Variant + EventType = _PropertyGet("EventType") +End Property ' EventType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FocusChangeTemporary() As Variant + FocusChangeTemporary = _PropertyGet("FocusChangeTemporary") +End Property ' FocusChangeTemporary (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyAlt() As Variant + KeyAlt = _PropertyGet("KeyAlt") +End Property ' KeyAlt (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyChar() As Variant + KeyChar = _PropertyGet("KeyChar") +End Property ' KeyChar (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyCode() As Variant + KeyCode = _PropertyGet("KeyCode") +End Property ' KeyCode (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyCtrl() As Variant + KeyCtrl = _PropertyGet("KeyCtrl") +End Property ' KeyCtrl (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyFunction() As Variant + KeyFunction = _PropertyGet("KeyFunction") +End Property ' KeyFunction (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get KeyShift() As Variant + KeyShift = _PropertyGet("KeyShift") +End Property ' KeyShift (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Recommendation() As Variant + Recommendation = _PropertyGet("Recommendation") +End Property ' Recommendation (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RowChangeAction() As Variant + RowChangeAction = _PropertyGet("RowChangeAction") +End Property ' RowChangeAction (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Source() As Variant +' Return the object having fired the event: Form, Control or SubForm +' Else return the root Database object + Source = _PropertyGet("Source") +End Function ' Source (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SubComponentName() As String + SubComponentName = _PropertyGet("SubComponentName") +End Property ' SubComponentName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SubComponentType() As Long + SubComponentType = _PropertyGet("SubComponentType") +End Property ' SubComponentType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get XPos() As Variant + XPos = _PropertyGet("XPos") +End Property ' XPos (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get YPos() As Variant + YPos = _PropertyGet("YPos") +End Property ' YPos (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Form.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Form.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize(poEvent As Object) + +Dim oObject As Object, i As Integer +Dim sShortcut As String, sAddShortcut As String, sArray() As String +Dim sImplementation As String, oSelection As Object +Dim iCurrentDoc As Integer, oDoc As Object +Dim vPersistent As Variant +Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set oObject = poEvent.Source + _EventSource = oObject + sArray = Split(Utils._getUNOTypeName(poEvent), ".") + _EventType = UCase(sArray(UBound(sArray))) + If Utils._hasUNOProperty(poEvent, "EventName") Then _EventName = poEvent.EventName + + Select Case _EventType + Case "DOCUMENTEVENT" + 'SubComponent processing + Select Case UCase(_EventName) + Case UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") + Set oSelection = poEvent.ViewController.getSelection()(0) + _SubComponentName = oSelection.Name + With com.sun.star.sdb.application.DatabaseObject + Select Case oSelection.Type + Case .TABLE : _SubComponentType = acTable + Case .QUERY : _SubComponentType = acQuery + Case .FORM : _SubComponentType = acForm + Case .REPORT : _SubComponentType = acReport + Case Else + End Select + End With + Case Else + End Select + Case "EVENTOBJECT" + Case "ACTIONEVENT" + Case "FOCUSEVENT" + _FocusChangeTemporary = poEvent.Temporary + Case "ITEMEVENT" + Case "INPUTEVENT", "KEYEVENT" + _KeyCode = poEvent.KeyCode + _KeyChar = poEvent.KeyChar + _KeyFunction = poEvent.KeyFunc + _KeyAlt = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD2) + _KeyCtrl = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD1) + _KeyShift = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.SHIFT) + Case "MOUSEEVENT" + _ButtonLeft = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.LEFT) + _ButtonRight = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.RIGHT) + _ButtonMiddle = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.MIDDLE) + _XPos = poEvent.X + _YPos = poEvent.Y + _ClickCount = poEvent.ClickCount + Case "ROWCHANGEEVENT" + _RowChangeAction = poEvent.Action + Case "TEXTEVENT" + Case "ADJUSTMENTEVENT", "DOCKINGEVENT", "ENDDOCKINGEVENT", "ENDPOPUPMODEEVENT", "ENHANCEDMOUSEEVENT" _ + , "MENUEVENT", "PAINTEVENT", "SPINEVENT", "VCLCONTAINEREVENT", "WINDOWEVENT" + Goto Exit_Function + Case Else + Goto Exit_Function + End Select + + ' Evaluate ContextShortcut + sShortcut = "" + sImplementation = Utils._ImplementationName(oObject) + + Select Case True + Case sImplementation = "stardiv.Toolkit.UnoDialogControl" ' Dialog + _ContextShortcut = "Dialogs!" & _EventSource.Model.Name + Goto Exit_Function + Case Left(sImplementation, 16) = "stardiv.Toolkit." ' Control in Dialog + _ContextShortcut = "Dialogs!" & _EventSource.Context.Model.Name _ + & "!" & _EventSource.Model.Name + Goto Exit_Function + Case Else + End Select + + iCurrentDoc = _A2B_.CurrentDocIndex(, False) + If iCurrentDoc < 0 Then Goto Exit_Function + Set oDoc = _A2B_.CurrentDocument(iCurrentDoc) + + ' To manage 2x triggers of "Before record action" form event + If _EventType = "ROWCHANGEEVENT" And sImplementation <> "com.sun.star.comp.forms.ODatabaseForm" Then _Recommendation = "IGNORE" + + Do While sImplementation <> "SwXTextDocument" + sAddShortcut = "" + Select Case sImplementation + Case "com.sun.star.comp.forms.OFormsCollection" ' Do nothing + Case Else + If Utils._hasUNOProperty(oObject, "Model") Then + If oObject.Model.Name <> "MainForm" And oObject.Model.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Model.Name) + ElseIf Utils._hasUNOProperty(oObject, "Name") Then + If oObject.Name <> "MainForm" And oObject.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Name) + End If + If sAddShortcut <> "" Then + If sImplementation = cstDatabaseForm And oDoc.DbConnect = DBCONNECTBASE Then sAddShortcut = sAddShortcut & ".Form" + sShortcut = sAddShortcut & Iif(Len(sShortcut) > 0, "!" & sShortcut, "") + End If + End Select + Select Case True + Case Utils._hasUNOProperty(oObject, "Model") + Set oObject = oObject.Model.Parent + Case Utils._hasUNOProperty(oObject, "Parent") + Set oObject = oObject.Parent + Case Else + Goto Exit_Function + End Select + sImplementation = Utils._ImplementationName(oObject) + Loop + ' Add Forms! prefix + Select Case oDoc.DbConnect + Case DBCONNECTBASE + vPersistent = Split(oObject.StringValue, "/") + sAddShortcut = Utils._Surround(_GetHierarchicalName(vPersistent(UBound(vPersistent) - 1))) + sShortcut = "Forms!" & sAddShortcut & "!" & sShortcut + Case DBCONNECTFORM + sShortcut = "Forms!0!" & sShortcut + End Select + + sArray = Split(sShortcut, "!") + ' If presence of "Forms!myform!myform.Form", eliminate 2nd element + ' Eliminate anyway blanco subcomponents (e.g. Forms!!myForm) + If UBound(sArray) >= 2 Then + If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then sArray(1) = "" + sArray = Utils._TrimArray(sArray) + End If + ' If first element ends with .Form, remove suffix + If UBound(sArray) >= 1 Then + If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then sArray(1) = left(sArray(1), Len(sArray(1)) - 5) + sShortcut = Join(sArray, "!") + End If + If Len(sShortcut) >= 2 Then + If Right(sShortcut, 1) = "!" Then + _ContextShortcut = Left(sShortcut, Len(sShortcut) - 1) + Else + _ContextShortcut = sShortcut + End If + End If + +Exit_Function: + Exit Sub +Error_Function: + TraceError(TRACEWARNING, Err, "Event.Initialize", Erl) + GoTo Exit_Function +End Sub ' _Initialize V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + +Dim sSubComponentName As String, sSubComponentType As String + sSubComponentName = Iif(_SubComponentType > -1, "SubComponentName", "") + sSubComponentType = Iif(_SubComponentType > -1, "SubComponentType", "") +Dim sXPos As String, sYPos As String + sXPos = Iif(IsNull(_XPos), "", "XPos") + sYPos = Iif(IsNull(_YPos), "", "YPos") + + _PropertiesList = Utils._TrimArray(Array( _ + "ButtonLeft", "ButtonRight", "ButtonMiddle", "ClickCount" _ + , "ContextShortcut", "EventName", "EventType", "FocusChangeTemporary", _ + , "KeyAlt", "KeyChar", "KeyCode", "KeyCtrl", "KeyFunction", "KeyShift" _ + , "ObjectType", "Recommendation", "RowChangeAction", "Source" _ + , sSubComponentName, sSubComponentType, sXPos, sYPos _ + )) + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Event.get" & psProperty) + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("ButtonLeft") + _PropertyGet = _ButtonLeft + Case UCase("ButtonMiddle") + _PropertyGet = _ButtonMiddle + Case UCase("ButtonRight") + _PropertyGet = _ButtonRight + Case UCase("ClickCount") + _PropertyGet = _ClickCount + Case UCase("ContextShortcut") + _PropertyGet = _ContextShortcut + Case UCase("FocusChangeTemporary") + _PropertyGet = _FocusChangeTemporary + Case UCase("EventName") + _PropertyGet = _EventName + Case UCase("EventSource") + _PropertyGet = _EventSource + Case UCase("EventType") + _PropertyGet = _EventType + Case UCase("KeyAlt") + _PropertyGet = _KeyAlt + Case UCase("KeyChar") + _PropertyGet = _KeyChar + Case UCase("KeyCode") + _PropertyGet = _KeyCode + Case UCase("KeyCtrl") + _PropertyGet = _KeyCtrl + Case UCase("KeyFunction") + _PropertyGet = _KeyFunction + Case UCase("KeyShift") + _PropertyGet = _KeyShift + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Recommendation") + _PropertyGet = _Recommendation + Case UCase("RowChangeAction") + _PropertyGet = _RowChangeAction + Case UCase("Source") + If _ContextShortcut = "" Then + _PropertyGet = _EventSource + Else + _PropertyGet = getObject(_ContextShortcut) + End If + Case UCase("SubComponentName") + _PropertyGet = _SubComponentName + Case UCase("SubComponentType") + _PropertyGet = _SubComponentType + Case UCase("XPos") + If IsNull(_XPos) Then Goto Trace_Error + _PropertyGet = _XPos + Case UCase("YPos") + If IsNull(_YPos) Then Goto Trace_Error + _PropertyGet = _YPos + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Event.get" & psProperty) + Exit Function +Trace_Error: + ' Errors are not displayed to avoid display infinite cycling + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, False, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet V1.1.0 + + \ No newline at end of file diff --git a/wizards/source/access2base/Field.xba b/wizards/source/access2base/Field.xba new file mode 100644 index 000000000..1fe2f185e --- /dev/null +++ b/wizards/source/access2base/Field.xba @@ -0,0 +1,923 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be FIELD +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Precision As Long +Private _ParentName As String +Private _ParentType As String +Private _ParentDatabase As Object +Private _ParentRecordset As Object +Private _DefaultValue As String +Private _DefaultValueSet As Boolean +Private Column As Object ' com.sun.star.sdb.OTableColumnWrapper + ' or org.openoffice.comp.dbaccess.OQueryColumn + ' or com.sun.star.sdb.ODataColumn + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJFIELD + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _ParentName = "" + _ParentType = "" + _DefaultValue = "" + _DefaultValueSet = False + Set Column = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get DataType() As Long ' AOO/LibO type + DataType = _PropertyGet("DataType") +End Property ' DataType (get) + +Property Get DataUpdatable() As Boolean + DataUpdatable = _PropertyGet("DataUpdatable") +End Property ' DataUpdatable (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get DbType() As Long ' MSAccess type + DbType = _PropertyGet("DbType") +End Property ' DbType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get DefaultValue() As Variant + DefaultValue = _PropertyGet("DefaultValue") +End Property ' DefaultValue (get) + +Property Let DefaultValue(ByVal pvDefaultValue As Variant) + Call _PropertySet("DefaultValue", pvDefaultValue) +End Property ' DefaultValue (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Description() As Variant + Description = _PropertyGet("Description") +End Property ' Description (get) + +Property Let Description(ByVal pvDescription As Variant) + Call _PropertySet("Description", pvDescription) +End Property ' Description (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FieldSize() As Long + FieldSize = _PropertyGet("FieldSize") +End Property ' FieldSize (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Size() As Long + Size = _PropertyGet("Size") +End Property ' Size (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SourceField() As String + SourceField = _PropertyGet("SourceField") +End Property ' SourceField (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SourceTable() As String + SourceTable = _PropertyGet("SourceTable") +End Property ' SourceTable (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get TypeName() As String + TypeName = _PropertyGet("TypeName") +End Property ' TypeName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AppendChunk(ByRef Optional pvValue As Variant) As Boolean +' Store a chunk of string or binary characters into the current field, presumably a large object (CLOB or BLOB) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Field.AppendChunk" + Utils._SetCalledSub(cstThisSub) + AppendChunk = False + + If IsMissing(pvValue) Then Call _TraceArguments() + + If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... ! + If Not Column.IsWritable Then Goto Trace_Error_Updatable + If Column.IsReadOnly Then Goto Trace_Error_Updatable + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + +Dim iChunkType As Integer + + With com.sun.star.sdbc.DataType + Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES +' Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB +' iChunkType = vbString + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB, .CHAR ' .CHAR added for Sqlite3 + iChunkType = vbByte + Case Else + Goto Trace_Error + End Select + End With + + AppendChunk = _ParentRecordset._AppendChunk(_Name, pvValue, iChunkType) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error_Updatable: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' AppendChunk V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetChunk(ByVal Optional pvOffset As Variant, ByVal Optional pvBytes As Variant) As Variant +' Get a chunk of string or binary characters from the current field, presumably a large object (CLOB or BLOB) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Field.GetChunk" + Utils._SetCalledSub(cstThisSub) + +Dim oValue As Object, bNullable As Boolean, bNull As Boolean, vValue() As Variant +Dim lLength As Long, lOffset As Long, lValue As Long + + If IsMissing(pvOffset) Or IsMissing(pvBytes) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvOffset, 1, _AddNumeric()) Then Goto Exit_Function + If pvOffset < 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvOffset)) + Goto Exit_Function + End If + If Not Utils._CheckArgument(pvBytes, 2, _AddNumeric()) Then Goto Exit_Function + If pvBytes < 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(2, pvBytes)) + Goto Exit_Function + End If + + bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE ) + bNull = False + GetChunk = Null + vValue = Array() + With com.sun.star.sdbc.DataType + Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES +' Case .CHAR, .VARCHAR, .LONGVARCHAR +' Set oValue = Column.getCharacterStream() +' Case .CLOB +' Set oValue = Column.getClob.getCharacterStream() + Case .BINARY, .VARBINARY, .LONGVARBINARY + Set oValue = Column.getBinaryStream() + Case .BLOB + Set oValue = Column.getBlob.getBinaryStream() + Case Else + Goto Trace_Error + End Select + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lOffset = CLng(pvOffset) + If lOffset > 0 Then oValue.skipBytes(lOffset) + lValue = oValue.readBytes(vValue, pvBytes) + End If + oValue.closeInput() + End With + GetChunk = vValue + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub) + Goto Exit_Function +Trace_Argument: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex)) + Set vForms = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' GetChunk V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Const cstThisSub = "Field.getProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + +Const cstThisSub = "Field.hasProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Utils._ResetCalledSub(cstThisSub) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String, sName As String +Const cstThisSub = "Field.Properties" + Utils._SetCalledSub(cstThisSub) + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + sName = _ParentType & "/" & _ParentName & "/" & _Name + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + Set vProperty._ParentDatabase = _ParentDatabase + End If + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ReadAllBytes(ByVal Optional pvFile As Variant) As Boolean +' Read the whole content of a file into Long Binary Field object + +Const cstThisSub = "Field.ReadAllBytes" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + ReadAllBytes = _ReadAll(pvFile, "ReadAllBytes") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ReadAllBytes + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ReadAllText(ByVal Optional pvFile As Variant) As Boolean +' Read the whole content of a file into a Long Char Field object + +Const cstThisSub = "Field.ReadAllText" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + ReadAllText = _ReadAll(pvFile, "ReadAllText") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ReadAllText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Const cstThisSub = "Field.setProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function WriteAllBytes(ByVal Optional pvFile As Variant) As Boolean +' Write the whole content of a Long Binary Field object to a file + +Const cstThisSub = "Field.WriteAllBytes" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + WriteAllBytes = _WriteAll(pvFile, "WriteAllBytes") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' WriteAllBytes + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function WriteAllText(ByVal Optional pvFile As Variant) As Boolean +' Write the whole content of a Long Char Field object to a file + +Const cstThisSub = "Field.WriteAllText" + Utils._SetCalledSub(cstThisSub) + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + WriteAllText = _WriteAll(pvFile, "WriteAllText") + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' WriteAllText + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + Select Case _ParentType + Case OBJTABLEDEF + _PropertiesList =Array("DataType", "dbType", "DefaultValue" _ + , "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _ + , "TypeName" _ + ) + Case OBJQUERYDEF + _PropertiesList = Array("DataType", "dbType", "DefaultValue" _ + , "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _ + , "TypeName" _ + ) + Case OBJRECORDSET + _PropertiesList = Array("DataType", "DataUpdatable", "dbType", "DefaultValue" _ + , "Description" , "FieldSize", "Name", "ObjectType" _ + , "Size", "SourceTable", "TypeName", "Value" _ + ) + End Select + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "Field.get" & psProperty + Utils._SetCalledSub(cstThisSub) + + If Not hasProperty(psProperty) Then Goto Trace_Error + +Dim bCond1 As Boolean, bCond2 As Boolean, vValue As Variant, oValue As Object, sValue As String +Dim oSize As Object, lSize As Long, bNullable As Boolean, bNull As Boolean +Const cstMaxBinlength = 2 * 65535 + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("DataType") + _PropertyGet = Column.Type + Case UCase("DbType") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BIT : _PropertyGet = dbBoolean + Case .TINYINT : _PropertyGet = dbInteger + Case .SMALLINT : _PropertyGet = dbLong + Case .INTEGER : _PropertyGet = dbLong + Case .BIGINT : _PropertyGet = dbBigInt + Case .FLOAT : _PropertyGet = dbFloat + Case .REAL : _PropertyGet = dbSingle + Case .DOUBLE : _PropertyGet = dbDouble + Case .NUMERIC : _PropertyGet = dbNumeric + Case .DECIMAL : _PropertyGet = dbDecimal + Case .CHAR : _PropertyGet = dbChar + Case .VARCHAR : _PropertyGet = dbText + Case .LONGVARCHAR : _PropertyGet = dbMemo + Case .CLOB : _PropertyGet = dbMemo + Case .DATE : _PropertyGet = dbDate + Case .TIME : _PropertyGet = dbTime + Case .TIMESTAMP : _PropertyGet = dbTimeStamp + Case .BINARY : _PropertyGet = dbBinary + Case .VARBINARY : _PropertyGet = dbVarBinary + Case .LONGVARBINARY : _PropertyGet = dbLongBinary + Case .BLOB : _PropertyGet = dbLongBinary + Case .BOOLEAN : _PropertyGet = dbBoolean + Case Else : _PropertyGet = dbUndefined + End Select + End With + Case UCase("DataUpdatable") + If Utils._hasUNOProperty(Column, "IsWritable") Then + _PropertyGet = Column.IsWritable + ElseIf Utils._hasUNOProperty(Column, "IsReadOnly") Then + _PropertyGet = Not Column.IsReadOnly + ElseIf Utils._hasUNOProperty(Column, "IsDefinitelyWritable") Then + _PropertyGet = Column.IsDefinitelyWritable + Else + _PropertyGet = False + End If + If Utils._hasUNOProperty(Column, "IsAutoIncrement") Then + If Column.IsAutoIncrement Then _PropertyGet = False ' Forces False if auto-increment (MSAccess) + End If + Case UCase("DefaultValue") + ' default value buffered to avoid multiple calls + If Not _DefaultValueSet Then + If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement + _DefaultValue = Column.DefaultValue + ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + If IsEmpty(Column.ControlDefault) Then _DefaultValue = "" Else _DefaultValue = Column.ControlDefault + Else + _DefaultValue = "" + End If + _DefaultValueSet = True + End If + _PropertyGet = _DefaultValue + Case UCase("Description") + bCond1 = Utils._hasUNOProperty(Column, "Description") + bCond2 = Utils._hasUNOProperty(Column, "HelpText") + Select Case True + Case ( bCond1 And bCond2 ) + If IsEmpty(Column.HelpText) Then _PropertyGet = Column.Description Else _PropertyGet = Column.HelpText + Case ( bCond1 And ( Not bCond2 ) ) + _PropertyGet = Column.Description + Case ( ( Not bCond1 ) And bCond2 ) + _PropertyGet = Column.HelpText + Case Else + _PropertyGet = "" + End Select + Case UCase("FieldSize") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .VARCHAR, .LONGVARCHAR, .CLOB + Set oSize = Column.getCharacterStream + Case .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB + Set oSize = Column.getBinaryStream + Case Else + Set oSize = Nothing + End Select + End With + If Not IsNull(oSize) Then + bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE ) + If bNullable Then + If Column.wasNull() Then _PropertyGet = 0 Else _PropertyGet = CLng(oSize.getLength()) + Else + _PropertyGet = CLng(oSize.getLength()) + End If + oSize.closeInput() + Else + _PropertyGet = EMPTY + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Size") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .LONGVARCHAR, .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB, .CLOB + _PropertyGet = 0 ' Always 0 (MSAccess) + Case Else + If Utils._hasUNOProperty(Column, "Precision") Then _PropertyGet = Column.Precision Else _PropertyGet = 0 + End Select + End With + Case UCase("SourceField") + Select Case _ParentType + Case OBJTABLEDEF + _PropertyGet = _Name + Case OBJQUERYDEF ' RealName = not documented ?!? + If Utils._hasUNOProperty(Column, "RealName") Then _PropertyGet = Column.RealName Else _PropertyGet = _Name + End Select + Case UCase("SourceTable") + Select Case _ParentType + Case OBJTABLEDEF + _PropertyGet = _ParentName + Case OBJQUERYDEF, OBJRECORDSET + _PropertyGet = Column.TableName + End Select + Case UCase("TypeName") + _PropertyGet = Column.TypeName + Case UCase("Value") + bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE ) + bNull = False + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BIT, .BOOLEAN : vValue = Column.getBoolean() ' vbBoolean + Case .TINYINT : vValue = Column.getShort() ' vbInteger + Case .SMALLINT, .INTEGER: vValue = Column.getInt() ' vbLong + Case .BIGINT : vValue = Column.getLong() ' vbBigint + Case .FLOAT : vValue = Column.getFloat() ' vbSingle + Case .REAL, .DOUBLE : vValue = Column.getDouble() ' vbDouble + Case .NUMERIC, .DECIMAL + If Utils._hasUNOProperty(Column, "Scale") Then + If Column.Scale > 0 Then + vValue = Column.getDouble() + Else ' Try Long otherwise Double (CDec not implemented anymore in LO ?!?) + On Local Error Resume Next ' Avoid overflow error + ' CLng checks local decimal point, getString does not ! + sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint()) + vValue = CLng(sValue) + If Err <> 0 Then + vValue = CDbl(sValue) + Err.Clear + On Local Error Goto Error_Function + End If + End If + Else + vValue = CDbl(Column.getString()) + End If + Case .CHAR : vValue = Column.getString() + Case .VARCHAR : vValue = Column.getString() ' vbString + Case .LONGVARCHAR, .CLOB + Set oValue = Column.getCharacterStream() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lSize = CLng(oValue.getLength()) + oValue.closeInput() + vValue = Column.getString() ' vbString + Else + oValue.closeInput() + End If + Case .DATE : Set oValue = Column.getDate() ' vbObject with members VarType Unsigned Short = 18 + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) + Case .TIME : Set oValue = Column.getTime() ' vbObject with members VarType Unsigned Short = 18 + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds) + Case .TIMESTAMP : Set oValue = Column.getTimeStamp() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) _ + + TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oValue = Column.getBinaryStream() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lSize = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize + If lSize > cstMaxBinlength Then Goto Trace_Length + vValue = Array() + oValue.readBytes(vValue, lSize) + End If + oValue.closeInput() + Case Else + vValue = Column.getString() 'GIVE STRING A TRY + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + If bNullable Then + If Column.wasNull() Then vValue = Null 'getXXX must precede wasNull() + End If + End With + _PropertyGet = vValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Length: + TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk")) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "Field.set" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertySet = True +Dim iArgNr As Integer, vTemp As Variant +Dim oParent As Object + + Select Case UCase(_A2B_.CalledSub) + Case UCase("setProperty") : iArgNr = 3 + Case UCase("Field.setProperty") : iArgNr = 2 + Case UCase(cstThisSub) : iArgNr = 1 + End Select + + If Not hasProperty(psProperty) Then Goto Trace_Error + + Select Case UCase(psProperty) + Case UCase("DefaultValue") + If _ParentType <> OBJTABLEDEF Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + Column.ControlDefault = pvValue + _DefaultValue = pvValue + _DefaultValueSet = True + End If + Case UCase("Description") + If _ParentType <> OBJTABLEDEF Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Column.HelpText = pvValue + Case UCase("Value") + If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... ! + If Not Column.IsWritable Then Goto Trace_Error_Updatable + If Column.IsReadOnly Then Goto Trace_Error_Updatable + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + With com.sun.star.sdbc.DataType + If IsNull(pvValue) Then + If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then Column.updateNull() Else Goto Trace_Null + Else + Select Case Column.Type + Case .BIT, .BOOLEAN + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + Column.updateBoolean(pvValue) + Case .TINYINT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -128 Or pvValue > +127 Then Goto Trace_Error_Value + Column.updateShort(CInt(pvValue)) + Case .SMALLINT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -32768 Or pvValue > 32767 Then Goto trace_Error_Value + Column.updateInt(CLng(pvValue)) + Case .INTEGER + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto trace_Error_Value + Column.updateInt(CLng(pvValue)) + Case .BIGINT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + Column.updateLong(pvValue) ' No proper type conversion for HYPER data type + Case .FLOAT + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then Column.updateFloat(CSng(pvValue)) Else Goto trace_Error_Value + Case .REAL, .DOUBLE + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value + Column.updateDouble(CDbl(pvValue)) + Case .NUMERIC, .DECIMAL + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(Column, "Scale") Then + If Column.Scale > 0 Then + 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value + Column.updateDouble(CDbl(pvValue)) + Else + Column.updateString(CStr(pvValue)) + End If + Else + Column.updateString(CStr(pvValue)) + End If + Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If _Precision > 0 And Len(pvValue) > _Precision Then Goto Trace_Error_Length + Column.updateString(pvValue) ' vbString + Case .DATE + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + vTemp = New com.sun.star.util.Date + With vTemp + .Day = Day(pvValue) + .Month = Month(pvValue) + .Year = Year(pvValue) + End With + Column.updateDate(vTemp) + Case .TIME + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + vTemp = New com.sun.star.util.Time + With vTemp + .Hours = Hour(pvValue) + .Minutes = Minute(pvValue) + .Seconds = Second(pvValue) + '.HundredthSeconds = 0 ' replaced with Long nanoSeconds in LO 4.1 ?? + End With + Column.updateTime(vTemp) + Case .TIMESTAMP + If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value + vTemp = New com.sun.star.util.DateTime + With vTemp + .Day = Day(pvValue) + .Month = Month(pvValue) + .Year = Year(pvValue) + .Hours = Hour(pvValue) + .Minutes = Minute(pvValue) + .Seconds = Second(pvValue) + '.HundredthSeconds = 0 + End With + Column.updateTimestamp(vTemp) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If Not IsArray(pvValue) Then Goto Trace_Error_Value + If UBound(pvValue) < LBound(pvValue) Then Goto Trace_Error_Value + If Not Utils._CheckArgument(pvValue(LBound(pvValue)), iArgNr, vbInteger, , False) Then Goto Trace_Error_Value + Column.updateBytes(pvValue) + Case Else + Goto trace_Error + End Select + End If + End With + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Trace_Null: + TraceError(TRACEFATAL, ERRNOTNULLABLE, Utils._CalledSub(), 0, 1, _Name) + _PropertySet = False + Goto Exit_Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error_Updatable: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1) + _PropertySet = False + Goto Exit_Function +Trace_Error_Length: + TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(Len(pvValue), "AppendChunk")) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReadAll(ByVal psFile As String, ByVal psMethod As String) As Boolean +' Write the whole content of a file into a stream object + + If _ErrorHandler() Then On Local Error Goto Error_Function + _ReadAll = False + + If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... ! + If Not Column.IsWritable Then Goto Trace_Error_Updatable + If Column.IsReadOnly Then Goto Trace_Error_Updatable + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + +Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object +Dim lFileLength As Long, sBuffer As String, sMemo As String, iFile As Integer +Const cstMaxLength = 64000 + sFile = ConvertToURL(psFile) + + oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + If Not oSimpleFileAccess.exists(sFile) Then Goto Trace_File + + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If psMethod <> "ReadAllBytes" Then Goto Trace_Error + Set oStream = oSimpleFileAccess.openFileRead(sFile) + lFileLength = oStream.getLength() + If lFileLength = 0 Then Goto Trace_File + Column.updateBinaryStream(oStream, lFileLength) + oStream.closeInput() + Case .VARCHAR, .LONGVARCHAR, .CLOB + If psMethod <> "ReadAllText" Then Goto Trace_Error + sMemo = "" + lFileLength = 0 + iFile = FreeFile() + Open sFile For Input Access Read Shared As iFile + Do While Not Eof(iFile) + Line Input #iFile, sBuffer + lFileLength = lFileLength + Len(sBuffer) + 1 + If lFileLength > cstMaxLength Then Exit Do + sMemo = sMemo & sBuffer & vbNewLine + Loop + If lFileLength = 0 Or lFileLength > cstMaxLength Then + Close #iFile + Goto Trace_File + End If + sMemo = Left(sMemo, lFileLength - 1) + Column.updateString(sMemo) + 'Column.updateCharacterStream(oStream, lFileLength) ' DOES NOT WORK ?!? + Case Else + Goto Trace_Error + End Select + End With + + _ReadAll = True + +Exit_Function: + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod) + Goto Exit_Function +Trace_File: + TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Trace_Error_Updatable: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, _CalledSub, Erl) + GoTo Exit_Function +End Function ' ReadAll + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _WriteAll(ByVal psFile As String, ByVal psMethod As String) As Boolean +' Write the whole content of a stream object to a file + + If _ErrorHandler() Then On Local Error Goto Error_Function + _WriteAll = False + +Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object + sFile = ConvertToURL(psFile) + + oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + If psMethod <> "WriteAllBytes" Then Goto Trace_Error + Set oStream = Column.getBinaryStream() + Case .VARCHAR, .LONGVARCHAR, .CLOB + If psMethod <> "WriteAllText" Then Goto Trace_Error + Set oStream = Column.getCharacterStream() + Case Else + Goto Trace_Error + End Select + End With + + If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then + If Column.wasNull() Then Goto Trace_Null + End If + If oStream.getLength() = 0 Then Goto Trace_Null + On Local Error Goto Trace_File + If oSimpleFileAccess.exists(sFile) Then oSimpleFileAccess.kill(sFile) + oSimpleFileAccess.writeFile(sFile, oStream) + On Local Error Goto Error_Function + oStream.closeInput() + + _WriteAll = True + +Exit_Function: + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod) + Goto Exit_Function +Trace_File: + TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Trace_Null: + TraceError(TRACEFATAL, ERRFIELDNULL, _CalledSub, 0) + If Not IsNull(oStream) Then oStream.closeInput() + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, _CalledSub, Erl) + GoTo Exit_Function +End Function ' WriteAll + + \ No newline at end of file diff --git a/wizards/source/access2base/Form.xba b/wizards/source/access2base/Form.xba new file mode 100644 index 000000000..df18feb34 --- /dev/null +++ b/wizards/source/access2base/Form.xba @@ -0,0 +1,1129 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be FORM +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Shortcut As String +Private _Name As String +Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure +Private _DbEntry As Integer +Private _MainForms As Variant +Private _PersistentName As String +Private _IsLoaded As Boolean +Private _OpenArgs As Variant +Private _OrderBy As String +Public Component As Object ' com.sun.star.text.TextDocument +Public ContainerWindow As Object ' (No name) +Public FormsCollection As Object ' com.sun.star.form.OFormsCollection +Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJFORM + Set _This = Nothing + Set _Parent = Nothing + _Shortcut = "" + _Name = "" + _DocEntry = -1 + _DbEntry = -1 + _MainForms = Array() + _PersistentName = "" + _IsLoaded = False + _OpenArgs = "" + _OrderBy = "" + Set Component = Nothing + Set ContainerWindow = Nothing + Set FormsCollection = Nothing + Set DatabaseForm = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() +Dim ofForm As Object + If Not IsLoaded(True) Then + If Not IsNull(DatabaseForm) Then DatabaseForm.Dispose() + End If + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowAdditions() As Variant + AllowAdditions = _PropertyGet("AllowAdditions") +End Property ' AllowAdditions (get) + +Property Let AllowAdditions(ByVal pvValue As Variant) + Call _PropertySet("AllowAdditions", pvValue) +End Property ' AllowAdditions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowDeletions() As Variant + AllowDeletions = _PropertyGet("AllowDeletions") +End Property ' AllowDeletions (get) + +Property Let AllowDeletions(ByVal pvValue As Variant) + Call _PropertySet("AllowDeletions", pvValue) +End Property ' AllowDeletions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowEdits() As Variant + AllowEdits = _PropertyGet("AllowEdits") +End Property ' AllowEdits (get) + +Property Let AllowEdits(ByVal pvValue As Variant) + Call _PropertySet("AllowEdits", pvValue) +End Property ' AllowEdits (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Bookmark() As Variant + Bookmark = _PropertyGet("Bookmark") +End Property ' Bookmark (get) + +Property Let Bookmark(ByVal pvValue As Variant) + Call _PropertySet("Bookmark", pvValue) +End Property ' Bookmark (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Caption() As Variant + Caption = _PropertyGet("Caption") +End Property ' Caption (get) + +Property Let Caption(ByVal pvValue As Variant) + Call _PropertySet("Caption", pvValue) +End Property ' Caption (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get CurrentRecord() As Variant + CurrentRecord = _PropertyGet("CurrentRecord") +End Property ' CurrentRecord (get) + +Property Let CurrentRecord(ByVal pvValue As Variant) + Call _PropertySet("CurrentRecord", pvValue) +End Property ' CurrentRecord (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Filter() As Variant + Filter = _PropertyGet("Filter") +End Property ' Filter (get) + +Property Let Filter(ByVal pvValue As Variant) + Call _PropertySet("Filter", pvValue) +End Property ' Filter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FilterOn() As Variant + FilterOn = _PropertyGet("FilterOn") +End Property ' FilterOn (get) + +Property Let FilterOn(ByVal pvValue As Variant) + Call _PropertySet("FilterOn", pvValue) +End Property ' FilterOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Height() As Variant + Height = _PropertyGet("Height") +End Property ' Height (get) + +Property Let Height(ByVal pvValue As Variant) + Call _PropertySet("Height", pvValue) +End Property ' Height (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Function IsLoaded(ByVal Optional pbForce As Boolean) As Boolean +'Return True if form open +'pbForce = True forbids bypass on value of _IsLoaded + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.getIsLoaded") + If IsMissing(pbForce) Then pbForce = False + If ( Not pbForce ) And _IsLoaded Then ' For performance reasons, a form object, once detected as loaded, is presumed remaining loaded. Except if pbForce = True + IsLoaded = True + Goto Exit_Function + End If + IsLoaded = False + +Dim oDoc As Object, oDatabase As Object, oEnum As Object, oDesk As Object, oComp As Object, vPersistent As Variant +Dim i As Integer + Set oDoc = _A2B_.CurrentDocument() + Select Case oDoc.DbConnect + Case DBCONNECTBASE + Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") + Set oEnum = oDesk.Components().createEnumeration + Do While oEnum.hasMoreElements ' Search in all open components if one corresponds with current form + oComp = oEnum.nextElement + If _hasUNOProperty(oComp, "Identifier") Then + If oComp.Identifier = "com.sun.star.sdb.FormDesign" Then + vPersistent = Split(oComp.StringValue, "/") + If vPersistent(UBound(vPersistent) - 1) = _PersistentName Then + _IsLoaded = True + Set Component = oComp + Exit Do + End If + End If + End If + Loop + Case DBCONNECTFORM + Set Component = oDoc.Document ' Form + _IsLoaded = True ' Interactive form always loaded by design + End Select + Set oComp = Nothing + IsLoaded = _IsLoaded + +Exit_Function: + Utils._ResetCalledSub("Form.getIsLoaded") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.getIsLoaded", Erl) + GoTo Exit_Function +End Function ' IsLoaded V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveCursorMove() As Variant + OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") +End Property ' OnApproveCursorMove (get) + +Property Let OnApproveCursorMove(ByVal pvValue As Variant) + Call _PropertySet("OnApproveCursorMove", pvValue) +End Property ' OnApproveCursorMove (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveParameter() As Variant + OnApproveParameter = _PropertyGet("OnApproveParameter") +End Property ' OnApproveParameter (get) + +Property Let OnApproveParameter(ByVal pvValue As Variant) + Call _PropertySet("OnApproveParameter", pvValue) + +End Property ' OnApproveParameter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' OnApproveReset (get) + +Property Let OnApproveReset(ByVal pvValue As Variant) + Call _PropertySet("OnApproveReset", pvValue) +End Property ' OnApproveReset (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveRowChange() As Variant + OnApproveRowChange = _PropertyGet("OnApproveRowChange") +End Property ' OnApproveRowChange (get) + +Property Let OnApproveRowChange(ByVal pvValue As Variant) + Call _PropertySet("OnApproveRowChange", pvValue) +End Property ' OnApproveRowChange (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveSubmit() As Variant + OnApproveSubmit = _PropertyGet("OnApproveSubmit") +End Property ' OnApproveSubmit (get) + +Property Let OnApproveSubmit(ByVal pvValue As Variant) + Call _PropertySet("OnApproveSubmit", pvValue) +End Property ' OnApproveSubmit (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnConfirmDelete() As Variant + OnConfirmDelete = _PropertyGet("OnConfirmDelete") +End Property ' OnConfirmDelete (get) + +Property Let OnConfirmDelete(ByVal pvValue As Variant) + Call _PropertySet("OnConfirmDelete", pvValue) +End Property ' OnConfirmDelete (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnCursorMoved() As Variant + OnCursorMoved = _PropertyGet("OnCursorMoved") +End Property ' OnCursorMoved (get) + +Property Let OnCursorMoved(ByVal pvValue As Variant) + Call _PropertySet("OnCursorMoved", pvValue) +End Property ' OnCursorMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' OnErrorOccurred (get) + +Property Let OnErrorOccurred(ByVal pvValue As Variant) + Call _PropertySet("OnErrorOccurred", pvValue) +End Property ' OnErrorOccurred (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoaded() As Variant + OnLoaded = _PropertyGet("OnLoaded") +End Property ' OnLoaded (get) + +Property Let OnLoaded(ByVal pvValue As Variant) + Call _PropertySet("OnLoaded", pvValue) +End Property ' OnLoaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloaded() As Variant + OnReloaded = _PropertyGet("OnReloaded") +End Property ' OnReloaded (get) + +Property Let OnReloaded(ByVal pvValue As Variant) + Call _PropertySet("OnReloaded", pvValue) +End Property ' OnReloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloading() As Variant + OnReloading = _PropertyGet("OnReloading") +End Property ' OnReloading (get) + +Property Let OnReloading(ByVal pvValue As Variant) + Call _PropertySet("OnReloading", pvValue) +End Property ' OnReloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnResetted() As Variant + OnResetted = _PropertyGet("OnResetted") +End Property ' OnResetted (get) + +Property Let OnResetted(ByVal pvValue As Variant) + Call _PropertySet("OnResetted", pvValue) +End Property ' OnResetted (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnRowChanged() As Variant + OnRowChanged = _PropertyGet("OnRowChanged") +End Property ' OnRowChanged (get) + +Property Let OnRowChanged(ByVal pvValue As Variant) + Call _PropertySet("OnRowChanged", pvValue) +End Property ' OnRowChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloaded() As Variant + OnUnloaded = _PropertyGet("OnUnloaded") +End Property ' OnUnloaded (get) + +Property Let OnUnloaded(ByVal pvValue As Variant) + Call _PropertySet("OnUnloaded", pvValue) +End Property ' OnUnloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloading() As Variant + OnUnloading = _PropertyGet("OnUnloading") +End Property ' OnUnloading (get) + +Property Let OnUnloading(ByVal pvValue As Variant) + Call _PropertySet("OnUnloading", pvValue) +End Property ' OnUnloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OpenArgs() As Variant + OpenArgs = _PropertyGet("OpenArgs") +End Property ' OpenArgs (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderBy() As Variant + OrderBy = _PropertyGet("OrderBy") +End Property ' OrderBy (get) V1.2.0 + +Property Let OrderBy(ByVal pvValue As Variant) + Call _PropertySet("OrderBy", pvValue) +End Property ' OrderBy (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderByOn() As Variant + OrderByOn = _PropertyGet("OrderByOn") +End Property ' OrderByOn (get) V1.2.0 + +Property Let OrderByOn(ByVal pvValue As Variant) + Call _PropertySet("OrderByOn", pvValue) +End Property ' OrderByOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name + +Const cstThisSub = "Form.OptionGroup" +Dim ogGroup As Object + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, Component, FormsCollection) + If Not IsNull(ogGroup) Then + ogGroup._DocEntry = _DocEntry + ogGroup._DbEntry = _DbEntry + End If + Set OptionGroup = ogGroup + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Form.OptionGroup, Erl) + GoTo Exit_Function +End Function ' OptionGroup V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + Parent = _Parent +End Function ' Parent (get) V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Recordset() As Object + Recordset = _PropertyGet("Recordset") +End Property ' Recordset (get) V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RecordSource() As Variant + RecordSource = _PropertyGet("RecordSource") +End Property ' RecordSource (get) + +Property Let RecordSource(ByVal pvValue As Variant) + Call _PropertySet("RecordSource", pvValue) +End Property ' RecordSource (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Visible() As Variant + Visible = _PropertyGet("Visible") +End Property ' Visible (get) + +Property Let Visible(ByVal pvValue As Variant) + Call _PropertySet("Visible", pvValue) +End Property ' Visible (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Width() As Variant + Width = _PropertyGet("Width") +End Property ' Width (get) + +Property Let Width(ByVal pvValue As Variant) + Call _PropertySet("Width", pvValue) +End Property ' Width (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function mClose() As Variant +' Close the form + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.Close") + mClose = False +Dim oDatabase As Object, oController As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + Set oController = oDatabase.Document.getFormDocuments.getByHierarchicalName(_Name) + oController.close() + Dispose() + mClose = True + +Exit_Function: + Utils._ResetCalledSub("Form.Close") + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Close", Erl) + GoTo Exit_Function +End Function ' Close + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.Controls") + +Dim ocControl As Variant, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer, iCount As Integer, sName As String, iAddCount As Integer +Dim oDatabaseForm As Object, iCtlCount As Integer + + Set ocControl = Nothing + If Not IsLoaded Then Goto Trace_Error_NotOpen + 'Count number of controls thru the forms collection + iControlCount = 0 + + iCount = FormsCollection.Count + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then iControlCount = iControlCount + oDatabaseForm.getCount() + Next i + + If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + oCounter._Count = iControlCount + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + + sName = "" + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + iAddCount = 0 + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + iCtlCount = oDatabaseForm.getCount() + If pvIndex >= iAddCount And pvIndex <= iAddcount + iCtlCount - 1 Then + sName = oDatabaseForm.ElementNames(pvIndex - iAddCount) + Exit For + End If + iAddCount = iAddcount +iCtlCount + End If + Next i + Case vbString ' Check control name validity (non case sensitive) + sIndex = UCase(Utils._Trim(pvIndex)) + bFound = False + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + sControls() = oDatabaseForm.getElementNames() + For j = 0 To UBound(sControls) + If UCase(sControls(j)) = sIndex Then + sName = sControls(j) + bFound = True + Exit For + End If + Next j + If bFound Then Exit For + End If + Next i + If Not bFound Then Goto Trace_NotFound + End Select + + 'Initialize a new Control object + Set ocControl = New Control + With ocControl + Set ._This = ocControl + Set ._Parent = _This + ._ParentType = CTLPARENTISFORM + ._Name = sName + ._Shortcut = _Shortcut & "!" & Utils._Surround(sName) + If IsNull(oDatabaseForm) Then ._MainForm = "" Else ._MainForm = oDatabaseForm.Name + Set .ControlModel = oDatabaseForm.getByName(sName) + ._ImplementationName = .ControlModel.getImplementationName() + ._FormComponent = Component + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + If ._ClassId > 0 And ._ClassId <> acHiddenControl Then + Set .ControlView = Component.CurrentController.getControl(.ControlModel) + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("Form.Controls") + Exit Function +Trace_Error_NotOpen: + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , _Name) + Set Controls = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex)) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns Database object related to current form + +Const cstThisSub = "Form.CurrentDb" + Utils._SetCalledSub(cstThisSub) + + Set CurrentDb = Application._CurrentDb(_DocEntry, _DbEntry) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Form.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Form.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move( ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute Move method + Utils._SetCalledSub("Form.Move") + If _ErrorHandler() Then On Local Error Goto Error_Function + Move = False +Dim iArgNr As Integer + Select Case UCase(_A2B_.CalledSub) + Case UCase("Move") : iArgNr = 1 + Case UCase("Form.Move") : iArgNr = 0 + End Select + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function + +Dim iArg As Integer, iWrong As Integer ' Check arguments values + iArg = 0 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If + If iArg > 0 Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) + Goto Exit_Function + End If + +Dim iPosSize As Integer + iPosSize = 0 + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + If iPosSize > 0 Then + If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + ContainerWindow.IsMaximized = False + ContainerWindow.IsMinimized = False + End If + ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) + End If + Move = True + +Exit_Function: + Utils._ResetCalledSub("Form.Move") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Move", Erl) + GoTo Exit_Function +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Refresh() As Boolean +' Refresh data with its most recent value in the database in a form or subform + Utils._SetCalledSub("Form.Refresh") + If _ErrorHandler() Then On Local Error Goto Error_Function + Refresh = False + +Dim oSet As Object + Set oSet = DatabaseForm.createResultSet() + If Not IsNull(oSet) Then + oSet.refreshRow() + Refresh = True + End If + +Exit_Function: + Set oSet = Nothing + Utils._ResetCalledSub("Form.Refresh") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl) + GoTo Exit_Function +End Function ' Refresh + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery() As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("Form.Requery") + If _ErrorHandler() Then On Local Error Goto Error_Function + Requery = False + + DatabaseForm.reload() + Requery = True + +Exit_Function: + Utils._ResetCalledSub("Form.Requery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Form.Requery", Erl) + GoTo Exit_Function +End Function ' Requery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFocus() As Boolean +' Execute setFocus method +Const cstThisSub = "Form.setFocus" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + setFocus = False + + With ContainerWindow + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .setEnable(True) ' Added to try to bypass desynchro issue in Linux + .toFront() ' Added to force window change in Linux + End With + setFocus = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Goto Exit_Function +End Function ' setFocus V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("Form.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("Form.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnApproveCursorMove") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveParameter") + _GetListener = "XDatabaseParameterListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveRowChange") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveSubmit") + _GetListener = "XSubmitListener" + Case UCase("OnConfirmDelete") + _GetListener = "XConfirmDeleteListener" + Case UCase("OnCursorMoved"), UCase("OnRowChanged") + _GetListener = "XRowSetListener" + Case UCase("OnErrorOccurred") + _GetListener = "XSQLErrorListener" + Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") + _GetListener = "XLoadListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize(psName As String) +' Set pointers to UNO objects + +Dim oDoc As Object, oDatabase As Object + If _ErrorHandler() Then On Local Error Goto Trace_Error + _Name = psName + _Shortcut = "Forms!" & Utils._Surround(psName) + Set oDoc = _A2B_.CurrentDocument() + If oDoc.DbConnect = DBCONNECTBASE Then _PersistentName = oDoc.Document.getFormDocuments().getByHierarchicalName(psName).PersistentName + If IsLoaded Then + Select Case oDoc.DbConnect + Case DBCONNECTBASE + If Not IsNull(Component.CurrentController) Then ' A form opened then closed afterwards keeps a Component attribute + Set ContainerWindow = Component.CurrentController.Frame.ContainerWindow + Set FormsCollection = Component.getDrawPage.Forms + If FormsCollection.Count = 0 Then + Set DatabaseForm = Nothing + Else + 'Only first member of the collection can be reached with A2B + 'Compliant with MSAccess which has 1 datasource by form, while LO might have many + _MainForms = FormsCollection.ElementNames() + Set DatabaseForm = FormsCollection.getByIndex(0) + End If + End If + Case DBCONNECTFORM + Set ContainerWindow = oDoc.Document.CurrentController.Frame.ContainerWindow + Set FormsCollection = oDoc.Document.getDrawPage.Forms + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + With oDatabase + Set DatabaseForm = .Form + If IsNull(.Connection) Then + Set .Connection = DatabaseForm.ActiveConnection + If Not IsNull(.Connection) Then + Set .MetaData = .Connection.MetaData + oDatabase._ReadOnly = .Connection.isReadOnly() + End If + End If + End With + End Select + If IsNull(DatabaseForm) Then _OrderBy = "" Else _OrderBy = DatabaseForm.Order + Else + Set Component = Nothing + Set ContainerWindow = Nothing + Set DatabaseForm = Nothing + End If + +Exit_Sub: + Exit Sub +Trace_Error: + TraceError(TRACEABORT, Err, "Form.Initialize", Erl) + Goto Exit_Sub +Trace_Internal_Error: + TraceError(TRACEABORT, ERRFORMNOTIDENTIFIED, Utils._CalledSub(), 0, , _Name) + Goto Exit_Sub +End Sub ' _Initialize V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + If _IsLoaded Then + _PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "Bookmark" _ + , "Caption", "CurrentRecord", "Filter", "FilterOn", "Height", "IsLoaded" _ + , "Name", "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _ + , "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _ + , "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _ + , "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OpenArgs" _ + , "OrderBy", "OrderByOn", "RecordSource", "Visible", "Width" _ + ) ' Recordset removed + Else + _PropertiesList = Array("IsLoaded", "Name" _ + ) + End If + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Form.get" & psProperty) + +'Execute +Dim oDatabase As Object, vBookmark As Variant +Dim i As Integer, oObject As Object + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("Name"), UCase("IsLoaded") + Case Else : If Not IsLoaded Then Goto Trace_Error_Form + End Select + + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowInserts + Case UCase("AllowDeletions") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowDeletes + Case UCase("AllowEdits") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowUpdates + Case UCase("Bookmark") + If IsNull(DatabaseForm) Then + _PropertyGet = 0 + Else + On Local Error Resume Next ' Disable error handler because bookmarking does not always react well in events ... + If DatabaseForm.IsBookmarkable Then vBookmark = DatabaseForm.getBookmark() Else vBookmark = Nothing + If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0 + If IsNull(vBookmark) Then Goto Trace_Error + _PropertyGet = vBookmark + End If + Case UCase("Caption") + Set odatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Select Case oDatabase._DbConnect + Case DBCONNECTFORM : _PropertyGet = oDatabase.Document.CurrentController.Frame.Title + Case DBCONNECTBASE : _PropertyGet = Component.CurrentController.Frame.Title + End Select + Case UCase("CurrentRecord") + If IsNull(DatabaseForm) Then _PropertyGet = 0 Else _PropertyGet = DatabaseForm.Row + Case UCase("Filter") + If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Filter + Case UCase("FilterOn") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.ApplyFilter + Case UCase("Height") + _PropertyGet = ContainerWindow.getPosSize().Height + Case UCase("IsLoaded") ' Only for indirect access from property object + _PropertyGet = IsLoaded + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name, True) + Case UCase("OpenArgs") + _PropertyGet = _OpenArgs + Case UCase("OrderBy") + _PropertyGet = _OrderBy + Case UCase("OrderByOn") + If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = ( DatabaseForm.Order <> "" ) + Case UCase("Recordset") + If IsNull(DatabaseForm) Then Goto Trace_Error + If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? + Set oObject = New Recordset + With DatabaseForm + oObject._This = oObject + oObject._CommandType = .CommandType + oObject._Command = .Command + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Set oObject._ParentDatabase = oDatabase + Set oObject._ParentDatabase.Connection = .ActiveConnection + oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) + oObject._PassThrough = ( .EscapeProcessing = False ) + oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) + Call oObject._Initialize() + End With + With oDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + Set _PropertyGet = oObject + Case UCase("RecordSource") + If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Command + Case UCase("Visible") + _PropertyGet = ContainerWindow.IsVisible() + Case UCase("Width") + _PropertyGet = ContainerWindow.getPosSize().Width + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Form.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Form: + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("Form.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer, i As Integer +Dim oDatabase As Object + + If _Isleft(_A2B_.CalledSub, "Form.") Then iArgNr = 1 Else iArgNr = 2 + If Not IsLoaded Then Goto Trace_Error_Form + + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.AllowInserts = pvValue + DatabaseForm.reload() + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.AllowDeletes = pvValue + DatabaseForm.reload() + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.AllowUpdates = pvValue + DatabaseForm.reload() + Case UCase("Bookmark") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbObject), , False) Then Goto Trace_Error_Value + If IsNull(pvValue) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.MoveToBookmark(pvValue) + Case UCase("Caption") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Select Case oDatabase._DbConnect + Case DBCONNECTFORM : oDatabase.Document.CurrentController.Frame.Title = pvValue + Case DBCONNECTBASE : Component.CurrentController.Frame.Title = pvValue + End Select + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.absolute(pvValue) + Case UCase("Filter") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.ApplyFilter = pvValue + DatabaseForm.reload() + Case UCase("Height") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + ContainerWindow.IsMaximized = False + ContainerWindow.IsMinimized = False + End If + ContainerWindow.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT) + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + If Not Utils._RegisterEventScript(DatabaseForm _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue, _Name, True _ + ) Then GoTo Trace_Error + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + _OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = "" + DatabaseForm.reload() + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If IsNull(DatabaseForm) Then Goto Trace_Error + DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND + DatabaseForm.Filter = "" + DatabaseForm.reload() + Case UCase("Visible") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + ContainerWindow.setVisible(pvValue) + Case UCase("Width") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 + ContainerWindow.IsMaximized = False + ContainerWindow.IsMinimized = False + End If + ContainerWindow.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Form.set" & psProperty) + Exit Function +Trace_Error_Form: + TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) + _PropertySet = False + Goto Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Form._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba new file mode 100644 index 000000000..ef11f6f3e --- /dev/null +++ b/wizards/source/access2base/L10N.xba @@ -0,0 +1,540 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _GetLabel(ByVal psShortlabel As String, Optional ByVal psLocale As String) As String +' Return the localized label corresponding with ShortLabel + + If IsMissing(psLocale) Then psLocale = UCase(Left(_A2B_.Locale, 2)) Else psLocale = UCase(psLocale) + On Local Error Goto Error_Function + If Not Utils._InList(psLocale, Array( _ + "EN", "FR", "ES", "DE" _ + )) Then psLocale = "DEFAULT" ' If list incomplete a recursive call will be provided anyway + +Dim sLocal As String + sLocal = psShortLabel + Select Case psLocale + Case "EN", "DEFAULT" + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No active connection to a database found" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Arguments are missing or are not initialized" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument nr. %0 [Value = '%1'] is invalid" + Case "ERR" & ERRMAINFORM : sLocal = "Document '%0' does not contain any form" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Form '%0' not identified in database Forms set" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "Form '%0' not found" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "Form '%0' is currently not open" + Case "ERR" & ERRDFUNCTION : sLocal = "DFunction execution failed, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "Form '%0' could not be opened" + Case "ERR" & ERRPROPERTY : sLocal = "Property '%0' not applicable in this context" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "Value '%0' is invalid for property '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Out of array range or incorrect array size for property '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Out of array range" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument nr.%0 should be an array" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Control '%0' not found in parent (form, grid or dialog) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "No active form or control found" + Case "ERR" & ERRDATABASEFORM : sLocal = "Form '%0' has no underlying dataset" + Case "ERR" & ERRFOCUSINGRID : sLocal = "Control '%0' not found in gridcontrol '%1'" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "No gridcontrol found in form '%0'" + Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() must be preceded by a successful FindRecord(...) call" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' not found" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' could not be opened" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' could not be closed" + Case "ERR" & ERRACTION : sLocal = "Action not applicable in this context" + Case "ERR" & ERRSENDMAIL : sLocal = "Mail service could not be activated" + Case "ERR" & ERRFORMYETOPEN : sLocal = "Form %0 is already open" + Case "ERR" & ERRMETHOD : sLocal = "Method '%0' not applicable in this context" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Property '%0' applicable but not initialized" + Case "ERR" & ERRFILENOTCREATED : sLocal = "File '%0' could not be created" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' not found in the currently loaded libraries" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unknown" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog already started" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' not active" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset delivered no data. Action on current record rejected" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset has been closed. Recordset action rejected" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "Current record out of range" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejected in a forward-only or not bookmarkable recordset" + Case "ERR" & ERRFIELDNULL : sLocal = "Field is null or empty. Action rejected" + Case "ERR" & ERRFILEACCESS : sLocal = "File access error on file '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "Field length (%0) exceeds maximum length. Use the '%1' method instead" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Query '%0' is not an action query" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "Database, recordset or field is read only" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Recordset update sequence error" + Case "ERR" & ERRNOTNULLABLE : sLocal = "Field '%0' must not contain a NULL value" + Case "ERR" & ERRROWDELETED : sLocal = "Current row has been deleted by another process or user" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "Cloning a cloned Recordset is forbidden" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Pre-existing query '%0' has been deleted" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Pre-existing table '%0' has been deleted" + Case "ERR" & ERRTABLECREATION : sLocal = "Table '%0' could not be created" + Case "ERR" & ERRFIELDCREATION : sLocal = "Field '%0' could not be created" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Subform '%0' not found in parent form '%1'" + Case "ERR" & ERRWINDOW : sLocal = "Current window is not a document" + Case "ERR" & ERRCOMPATIBILITY : sLocal = "Field '%0' could not be converted due to incompatibility of field types between the respective database systems" + Case "ERR" & ERRPRECISION : sLocal = "Field '%0' could not be loaded in record #%1 due to capacity shortage" + Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries" + Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'" + '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Object" + Case "TABLE" : sLocal = "Table" + Case "QUERY" : slocal = "Query" + Case "FORM" : sLocal = "Form" + Case "REPORT" : sLocal = "Report" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Field" + Case "TEMPVAR" : sLocal = "Temporary variable" + Case "COMMANDBAR" : sLocal = "Command bar" + Case "COMMANDBARCONTROL" : sLocal = "Command bar control" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "Error #" + Case "ERROCCUR" : sLocal = "occurred" + Case "ERRLINE" : sLocal = "at line" + Case "ERRIN" : sLocal = "in" + Case "CALLTO" : sLocal = "a call to function" + Case "SAVECONSOLE" : sLocal = "Save console" + Case "SAVECONSOLEENTRIES" : sLocal = "The console entries have been saved successfully." + Case "QUITSHORT" : sLocal = "Quit" + Case "QUIT" : sLocal = "Do you really want to quit the application ? Changed data will be saved." + Case "ENTERING" : sLocal = "Entering" + Case "EXITING" : sLocal = "Exiting" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Manage the console buffer and its entries" + Case "DLGTRACE_TITLE" : sLocal = "Console" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Clear the list and resize the circular buffer" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Set max number of entries" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text can be selected, copied, ..." + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log file is empty ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancel" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Clear the list" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Clear the list" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Register only logging requests above given level" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Set minimal trace level" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validate" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Choose a file and dump the actual list content in it" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Dump to file" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Actual size of list" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Actual number of entries:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Export the form" + Case "DLGFORMAT_TITLE" : sLocal = "OutputTo" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format in which the form should be exported" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Select the output format" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validate your choice" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancel" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = "" + End Select + Case "FR" + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Pas de connexion active trouvée à une banque de données" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Des arguments sont manquants ou non initialisés" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "L'argument n° %0 [Valeur = '%1'] n'est pas valable" + Case "ERR" & ERRMAINFORM : sLocal = "Le document '%0' ne contient aucun formulaire" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Le formulaire '%0' n'a pas pu être identifié parmi l'ensemble des formulaires de la Database" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formulaire '%0' non trouvé" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "Le formulaire '%0' n'est actuellement pas ouvert" + Case "ERR" & ERRDFUNCTION : sLocal = "L'exécution de la ""fonction database"" a échoué, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "Le formulaire '%0' n'a pas pu être ouvert" + Case "ERR" & ERRPROPERTY : sLocal = "La propriété '%0' n'est pas applicable dans ce contexte" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "La valeur '%0' est invalide pour la propriété '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Indice invalide ou dimension erronée du tableau pour la propriété '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Indice de tableau invalide" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "L'argument n°%0 doit être un tableau" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Contrôle '%0' non trouvé dans le parent (formulaire, contrôle de table ou dialogue) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "Pas de formulaire ou de contrôle actif" + Case "ERR" & ERRDATABASEFORM : sLocal = "Le formulaire '%0' n'a pas de données sous-jacentes" + Case "ERR" & ERRFOCUSINGRID : sLocal = "Contrôle '%0' non trouvé dans le contrôle de table '%1'" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "Aucun contrôle de table trouvé dans le formulaire '%0'" + Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() doit être précédé par un appel réussi à FindRecord(...)" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "Erreur SQL, instruction SQL = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' non trouvé(e)" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1': ouverture en échec" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1': fermeture en échec" + Case "ERR" & ERRACTION : sLocal = "Action non applicable dans ce contexte" + Case "ERR" & ERRSENDMAIL : sLocal = "Le service de messagerie n'a pas pu être activé" + Case "ERR" & ERRFORMYETOPEN : sLocal = "Le formulaire %0 est déjà ouvert" + Case "ERR" & ERRMETHOD : sLocal = "La méthode '%0' n'est pas applicable dans ce contexte" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Propriété '%0' applicable mais non initialisée" + Case "ERR" & ERRFILENOTCREATED : sLocal = "Erreur de création du fichier '%0'" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialogue '%0' introuvable dans les librairies chargées actuellement" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Boîte de dialogue inconnue" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialogue déjà initialisé précédemment" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialogue '%0' non initialisé" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset n'a pas fourni de données. Toute action sur les enregistrements est rejetée" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset a été clôturé. Action sur l'enregistrement courant est rejetée" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "L'enregistrement courant est hors cadre" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejetée car recordset lisible seulement vers l'avant ou n'acceptant pas de signets" + Case "ERR" & ERRFIELDNULL : sLocal = "Champ nul ou vide. Action rejetée" + Case "ERR" & ERRFILEACCESS : sLocal = "Erreur d'accès au fichier '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "La longueur du champ (%0) dépasse la taille maximale autorisée. Utiliser de préférence la méthode '%1'" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La requête '%0' n'est pas une requête d'action" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "La banque de données, le recordset ou le champ sont en lecture seulement" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Erreur de séquence lors de la mise à jour d'un Recordset" + Case "ERR" & ERRNOTNULLABLE : sLocal = "Le champ '%0' ne peut pas recevoir une valeur NULLe" + Case "ERR" & ERRROWDELETED : sLocal = "L'enregistrement courant a été effacé par un autre processus ou un autre utilisateur" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "Le clonage d'un Recordset cloné est interdit" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "La requête existante '%0' a été supprimée" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "La table existante '%0' a été supprimée" + Case "ERR" & ERRTABLECREATION : sLocal = "La table '%0' n'a pas pu être créée" + Case "ERR" & ERRFIELDCREATION : sLocal = "Le champ '%0' n'a pas pu être créé" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Sous-formulaire '%0' non trouvé dans le formulaire parent '%1'" + Case "ERR" & ERRWINDOW : sLocal = "La fenêtre courante n'est pas un document" + Case "ERR" & ERRCOMPATIBILITY : sLocal = "Le champ '%0' n'a pas pu être converti à cause d'une incompatibilité entre les types de champs supportés par les systèmes de bases de données respectifs" + Case "ERR" & ERRPRECISION : sLocal = "Le champ '%0' n'a pas pu être chargé dans l'enregistrement #%1 par manque de capacité" + Case "ERR" & ERRMODULENOTFOUND : sLocal = "Le module '%0' est introuvable dans les librairies chargées actuellement" + Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "La procédure '%0' est introuvable dans le module '%1'" + '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Objet" + Case "TABLE" : sLocal = "Table" + Case "QUERY" : slocal = "Requête" + Case "FORM" : sLocal = "Formulaire" + Case "REPORT" : sLocal = "Rapport" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Champ" + Case "TEMPVAR" : sLocal = "Variable temporaire" + Case "COMMANDBAR" : sLocal = "Barre de commande" + Case "COMMANDBARCONTROL" : sLocal = "Elément de barre de commande" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "L'erreur #" + Case "ERROCCUR" : sLocal = "s'est produite" + Case "ERRLINE" : sLocal = "à la ligne" + Case "ERRIN" : sLocal = "dans" + Case "CALLTO" : sLocal = "un appel à la fonction" + Case "SAVECONSOLE" : sLocal = "Sauver console" + Case "SAVECONSOLEENTRIES" : sLocal = "Les entrées de la console ont été sauvées avec succès." + Case "QUITSHORT" : sLocal = "Quitter" + Case "QUIT" : sLocal = "Voulez-vous réellement quitter l'application ? Les données modifiées seront sauvées." + Case "ENTERING" : sLocal = "Entrée dans" + Case "EXITING" : sLocal = "Sortie de" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Gestion du tampon de la console et toutes ses entrées" + Case "DLGTRACE_TITLE" : sLocal = "Console" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Effacer la liste et redimensionner le tampon circulaire" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Définir le nombre maximum d'entrées" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Le texte peut être sélectionné, copié, ..." + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Le fichier journal est vide ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Annuler" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Effacer la liste" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Effacer la liste" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "N'enregistrer que les demandes de journalisation à partir du niveau indiqué" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Définir le niveau minimal d'enregistrement" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Valider" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Sélectionner un fichier et y vider le contenu actuel des traces enregistrées" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Vider dans fichier" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Taille actuelle de la liste" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Nombre actuel d'entrées:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Exporter le formulaire" + Case "DLGFORMAT_TITLE" : sLocal = "OutputTo" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format dans lequel le formulaire sera exporté" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Selectionner le format de sortie" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Valider votre choix" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Annuler" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select +'******************************************************** +'Translated by Iñigo Zuluaga +'******************************************************** + Case "ES" '(España) + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No se ha encontrado una conexión activa a una base de datos" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Faltan argumentos o no están inicializados" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "El argumento nr. %0 [Value = '%1'] no es válido" + Case "ERR" & ERRMAINFORM : sLocal = "El documento '%0' no contiene ningún formulario" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "No se ha identificado el formulario '%0' en el conjunto de formularios de la base de datos" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "No se ha encontrado el formulario '%0'" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "El formulario '%0' no está abierto" + Case "ERR" & ERRDFUNCTION : sLocal = "La ejecución de DFunction falló, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "El formulario '%0' no se puede abrir" + Case "ERR" & ERRPROPERTY : sLocal = "La propiedad '%0' no es aplicable en este contexto" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "El valor '%0' es inválido para la propiedad '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Fuera del rango de la matriz o tamaño incorrecto de la matriz para la propiedad '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Fuera del rango de la matriz" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "El argumento nr.%0 debería ser una matriz" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "El control '%0' not found in parent (formulario, control de tabla or diálogo) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "No se ha encontrado un formulario o control activo" + Case "ERR" & ERRDATABASEFORM : sLocal = "El formulario '%0' no tiene datos subyacentes" + Case "ERR" & ERRFOCUSINGRID : sLocal = "No se ha encontrado el control '%0' en el control de tabla '%1'" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "No se ha encontrado un control de tabla en el formulario '%0'" + Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() tiene que ser precedido por una llamada exitosa de FindRecord(...)" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "Error SQL, instrución SQL = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' no encontrado" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' no se puede abrir" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' no se puede abrir" + Case "ERR" & ERRACTION : sLocal = "Acción no aplicable en este contexto" + Case "ERR" & ERRSENDMAIL : sLocal = "No se puede activar el servicio de correo" + Case "ERR" & ERRFORMYETOPEN : sLocal = "El formulario %0 ya está abierto" + Case "ERR" & ERRMETHOD : sLocal = "El método '%0' no es aplicable en este contexto" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Propiedad '%0' aplicable pero no inicializada" + Case "ERR" & ERRFILENOTCREATED : sLocal = "No se ha podido crear el archivo '%0'" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "No se ha encontrado el diálogo '%0' en las bibliotecas cargadas actualmente" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Diálogo desconocido" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "El diálogo ya está iniciado" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "El diálogo '%0' no está activo" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "El Recordset no suministra datos. La acción en el registro actual rechazada" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "El recorset se ha cerrado. Acción con el Recordset rechazada" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "Registro actual fuera de rango" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Acción rechazada en un recorset legible sólo hacia adelante o que no admita marcadores" + Case "ERR" & ERRFIELDNULL : sLocal = "El campo es nulo o vacío. Acción rechazada" + Case "ERR" & ERRFILEACCESS : sLocal = "Error durante el acceso al archivo '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "La longitud del campo (%0) excede la longitud máxima. Reemplazar por el método '%1'" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La consulta '%0' no es una consulta de acción" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "La base de datos, el Recordset o el Campo es de sólo lectura" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Error durante la secuencia de actualización del Recordset" + Case "ERR" & ERRNOTNULLABLE : sLocal = "El campo '%0' no puede contener un valor NULL" + Case "ERR" & ERRROWDELETED : sLocal = "La fila actual ha sido borrada por otro proceso o usuario" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "No se puede clonar un Recordset clonado" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Se ha borrado la consulta pre-existente '%0'" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Se ha borrado la tabla pre-existente '%0'" + Case "ERR" & ERRTABLECREATION : sLocal = "No se ha podido crear la Tabla '%0'" + Case "ERR" & ERRFIELDCREATION : sLocal = "No se ha podido crear el campo '%0'" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "No se ha encontrado el Subformulario '%0' en el subformulario padre '%1'" + Case "ERR" & ERRWINDOW : sLocal = "La ventana actual no es un documento" + Case "ERR" & ERRCOMPATIBILITY : sLocal = "El campo '%0' no se ha convertido debido a una incompatibilidad de los tipos de campo soportados entre las dos bases de datos" + Case "ERR" & ERRPRECISION : sLocal = "El campo '%0' no se ha cargado en el registro #%1 por falta de capacidad" + Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries" + Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'" + '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Objeto" + Case "TABLE" : sLocal = "Tabla" + Case "QUERY" : slocal = "Consulta" + Case "FORM" : sLocal = "Formulario" + Case "REPORT" : sLocal = "Informe" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Campo" + Case "TEMPVAR" : sLocal = "Variable temporal" + Case "COMMANDBAR" : sLocal = "Barra de comandos" + Case "COMMANDBARCONTROL" : sLocal = "Control de barra de comandos" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "Error #" + Case "ERROCCUR" : sLocal = "ocurrido" + Case "ERRLINE" : sLocal = "en línea" + Case "ERRIN" : sLocal = "en" + Case "CALLTO" : sLocal = "una llamada a la función" + Case "SAVECONSOLE" : sLocal = "Guardar consola" + Case "SAVECONSOLEENTRIES" : sLocal = "Las entradas de la consola han sido guardadas correctamente." + Case "QUITSHORT" : sLocal = "Cerrar" + Case "QUIT" : sLocal = "Quieres realmente cerrar la aplicación? los datos cambiados se guardarán." + Case "ENTERING" : sLocal = "Entrando" + Case "EXITING" : sLocal = "Saliendo" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Gestión del buffer de la consola y sus entradas" + Case "DLGTRACE_TITLE" : sLocal = "Consola" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Limpiar la lista y redimensionar el buffer circular" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Definir el número máximo de entradas" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "El texto puede ser seleccionado, copiado, ..." + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- El archivo Histórico está vacío ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancelar" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Limpiar la lista" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Limpiar la lista" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "No registrar más que las peticiones de registro a partir de un nivel indicado" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Definir el nivel mínimo de registro" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validar" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "Aceptar" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Elegir un archivo y guardar en él el contenido de la lista actual" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Guardar en a archivo" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Tamaño actual de la lista" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Numero actual de entradas:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Exportar el formulario" + Case "DLGFORMAT_TITLE" : sLocal = "Exportar como" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Formato en el que será ser exportado el formulario" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Seleccionar el formato de salida" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validar su elección" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "Aceptar" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancelar" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select +'******************************************************** +'Translated by Gisbert Friege +'******************************************************** + Case "DE" + Select Case UCase(psShortlabel) + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Keine aktive Verbindung zu einer Datenbank gefunden" + Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Argumente fehlen oder sind nicht initialisiert" + Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument Nr. %0 [Wert = '%1'] ist ungültig" + Case "ERR" & ERRMAINFORM : sLocal = "Dokument '%0' enthält kein Formular" + Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Formular '%0' nicht bei den Datenbank-Formularen erkannt" + Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formular '%0' nicht gefunden" + Case "ERR" & ERRFORMNOTOPEN : sLocal = "Formular '%0' ist zur Zeit nicht offen" + Case "ERR" & ERRDFUNCTION : sLocal = "DFunction Ausführung misslungen, SQL=%0" + Case "ERR" & ERROPENFORM : sLocal = "Formular '%0' konnte nicht geöffnet werden" + Case "ERR" & ERRPROPERTY : sLocal = "Eigenschaft '%0' in diesem Kontext nicht anwendbar" + Case "ERR" & ERRPROPERTYVALUE : sLocal = "Wert '%0' ist ungültig für die Eigenschaft '%1'" + Case "ERR" & ERRINDEXVALUE : sLocal = "Außerhalb des Array-Bereichs oder falsche Array-Größe für Eigenschaft '%0'" + Case "ERR" & ERRCOLLECTION : sLocal = "Außerhalb des Array-Bereichs" + Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument Nr.%0 sollte ein Array sein" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Steuerelement '%0' nicht gefunden in parent (Formular, Tabelle oder Dialog) '%1'" + Case "ERR" & ERRNOACTIVEFORM : sLocal = "Kein aktives Formular oder Steuerelement gefunden" + Case "ERR" & ERRDATABASEFORM : sLocal = "Formular '%0' basiert nicht auf einem Datensatz" + Case "ERR" & ERRFOCUSINGRID : sLocal = "Steuerelement '%0' im Tabellen-Steuerelement '%1' nicht gefunden" + Case "ERR" & ERRNOGRIDINFORM : sLocal = "Kein Tabellen-Steuerelement im Formular '%0' gefunden" + Case "ERR" & ERRFINDRECORD : sLocal = "Bei FindNext() muss ein erfolgreicher FindRecord(...)-Aufruf vorhergehen" + Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'" + Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' nicht gefunden" + Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' konnte nicht geöffnet werden" + Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' konnte nicht geschlossen werden" + Case "ERR" & ERRACTION : sLocal = "Aktion in diesem Kontext nicht anwendbar" + Case "ERR" & ERRSENDMAIL : sLocal = "Email-Dienst konnte nicht aktiviert werden" + Case "ERR" & ERRFORMYETOPEN : sLocal = "Formular %0 ist schon offen" + Case "ERR" & ERRMETHOD : sLocal = "Methode '%0' in diesem Kontext nicht anwendbar" + Case "ERR" & ERRPROPERTYINIT : sLocal = "Eigenschaft '%0' anwendbar aber nicht initialisiert" + Case "ERR" & ERRFILENOTCREATED : sLocal = "Datei '%0' konnte nicht erzeugt werden" + Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' nicht in den aktuell geladenen Bibliotheken gefunden" + Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unbekannt" + Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog schon gestartet" + Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' nicht aktiv" + Case "ERR" & ERRRECORDSETNODATA : sLocal = "Datensatz ergab keine Daten. Aktion auf aktuellem Datensatz verweigert" + Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Datensatz wurde geschlossen. Datensatz-Aktion verweigert" + Case "ERR" & ERRRECORDSETRANGE : sLocal = "Aktueller Datensatz außerhalb des Bereichs" + Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Aktion verweigert auf einem nur vorwärts lesbaren oder keine Textmarken unterstützenden Datensatz" + Case "ERR" & ERRFIELDNULL : sLocal = "Feld ist null oder leer. Aktion verweigert" + Case "ERR" & ERRFILEACCESS : sLocal = "Dateizugriffs-Fehler bei Datei '%0'" + Case "ERR" & ERROVERFLOW : sLocal = "Feldlänge (%0) überschreitet die maximale Länge. Verwende stattdessen die Methode '%1'" + Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Abfrage '%0' ist keine Aktionsabfrage" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "Datenbank, Datensatz oder Feld kann nur gelesen werden" + Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Datensatz-Update Folgefehler" + Case "ERR" & ERRNOTNULLABLE : sLocal = "Feld '%0' darf keinen NULL-Wert haben" + Case "ERR" & ERRROWDELETED : sLocal = "Aktuelle Zeile wurde durch einen anderen Prozess oder Benutzer gelösch" + Case "ERR" & ERRRECORDSETCLONE : sLocal = "Ein geklonter Datensatz kann nicht geklont werden" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Bereits vorhandene Abfrage '%0' wurde gelöscht" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Bereits vorhandene Tabelle '%0' wurde gelöscht" + Case "ERR" & ERRTABLECREATION : sLocal = "Tabelle '%0' konnte nicht erzeugt werden" + Case "ERR" & ERRFIELDCREATION : sLocal = "Feld '%0' konnte nicht erzeugt werden" + Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Unterformular '%0' nicht im Eltern-Formular '%1‘ gefunden" + Case "ERR" & ERRWINDOW : sLocal = "Aktuelles Fenster ist kein Dokument" + Case "ERR" & ERRCOMPATIBILITY : sLocal = "Feld '%0' konnte wegen inkompatibler Feldtypen der Datenbanksysteme nicht konvertiert werden" + Case "ERR" & ERRPRECISION : sLocal = "Feld '%0' konnte wegen fehlender Speicherkapazität nicht in den Datensatz #%1 geladen werden" + Case "ERR" & ERRMODULENOTFOUND : sLocal = "Modul '%0' nicht gefunden in den aktuell geladen Bibliotheken" + Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Prozedur '%0' im Modul '%1' nicht gefunden" + '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Objekt" + Case "TABLE" : sLocal = "Tabelle" + Case "QUERY" : slocal = "Abfrage" + Case "FORM" : sLocal = "Formular" + Case "REPORT" : sLocal = "Report" + Case "RECORDSET" : sLocal = "Datensatz" + Case "FIELD" : sLocal = "Feld" + Case "TEMPVAR" : sLocal = "Temporäre Variable" + Case "COMMANDBAR" : sLocal = "Befehlsleiste" + Case "COMMANDBARCONTROL" : sLocal = "Befehlsleisten-Steuerelement" + '---------------------------------------------------------------------------------------------------------------------- + Case "ERR#" : sLocal = "Error #" + Case "ERROCCUR" : sLocal = "aufgetreten" + Case "ERRLINE" : sLocal = "in Zeile" + Case "ERRIN" : sLocal = "in" + Case "CALLTO" : sLocal = "ein Funktionsaufruf" + Case "SAVECONSOLE" : sLocal = "Konsoleneingaben sichern" + Case "SAVECONSOLEENTRIES" : sLocal = "Die Konsoleneingaben wurden erfolgreich gesichert." + Case "QUITSHORT" : sLocal = "Beenden" + Case "QUIT" : sLocal = "Wollen Sie wirklich die Anwendung beenden? Geänderte Daten werden gesichert." + Case "ENTERING" : sLocal = "Beginne mit" + Case "EXITING" : sLocal = "Verlasse" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGTRACE_HELP" : sLocal = "Verwalte den Konsolenpuffer und seine Eingaben" + Case "DLGTRACE_TITLE" : sLocal = "Konsole" + Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Leere die Liste und ändere die Größe des Umlaufpuffers" + Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Setze maximale Anzahl von Eingaben" + Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text kann ausgewählt, kopiert, ... werden" + Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log Datei ist leer ---" + Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen" + Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Abbrechen" + Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Leere die Liste" + Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Leere die Liste" + Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Registriere nur Logging-Anfragen oberhalb des gegebenen Levels" + Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Setze minimalen Fehlerbehandlungs-Level" + Case "DLGTRACE_CMDOK_HELP" : sLocal = "Übernehmen" + Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK" + Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Wähle eine Datei und speichere darin den aktuellen Listeninhalt" + Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Ausgabe in Datei" + Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Aktuelle Länge der Liste" + Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Aktuelle Anzahl von Einträgen:" + '---------------------------------------------------------------------------------------------------------------------- + Case "DLGFORMAT_HELP" : sLocal = "Exportiere das Formular" + Case "DLGFORMAT_TITLE" : sLocal = "Export" + Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format, in dem das Formular exportiert werden soll" + Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Wähle das Ausgabe-Format" + Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Auswahl übernehmen" + Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK" + Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen" + Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Abbrechen" + '---------------------------------------------------------------------------------------------------------------------- + Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select +REM ******************************************************************************************************************************************* +REM *** *** +REM *** ANY OTHER LANGUAGE TO BE INSERTED HERE *** +REM *** *** +REM ******************************************************************************************************************************************* + Case Else + sLocal = _Getlabel(psShortLabel, "DEFAULT") + End Select + +Exit_Function: + _Getlabel = sLocal + Exit Function +Error_Function: + sLocal = psShortLabel + GoTo Exit_Function +End Function ' GetLabel V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetLabelArray(ByVal pvShortlabel As Variant, Optional ByVal psLocale As String) As Variant +' Return the localized label corresponding with the ShortLabel array of strings + + If IsMissing(psLocale) Then psLocale = UCase(Left(_GetLocale(), 2)) Else psLocale = UCase(psLocale) + On Local Error Goto Error_Function + +Dim vLocal() As Variant, i As integer + vLocal = Array() + + If Not IsArray(pvShortLabel) Then + vLocal = _GetLabel(pvShortLabel, psLocale) + Goto Exit_Function + End If + + ReDim vLocal(LBound(pvShortLabel) To UBound(pvShortlabel)) + For i = LBound(pvShortLabel) To UBound(pvShortlabel) + vLocal(i) = _GetLabel(pvShortLabel(i), psLocale) + Next i + +Exit_Function: + _GetlabelArray = vLocal() + Exit Function +Error_Function: + vLocal = Array() + GoTo Exit_Function +End Function ' GetLabelArray V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetLocale() as String +'Return OO localization +'Derived from Tools library + +Dim oLocale as Object + oLocale = _GetRegistryKeyContent("org.openoffice.Setup/L10N") + _GetLocale = oLocale.getByName("ooLocale") +End Function ' GetLocale V0.8.9 + + \ No newline at end of file diff --git a/wizards/source/access2base/Methods.xba b/wizards/source/access2base/Methods.xba new file mode 100644 index 000000000..7f809c6c1 --- /dev/null +++ b/wizards/source/access2base/Methods.xba @@ -0,0 +1,300 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AddItem(Optional pvBox As Variant, ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean +' Add an item in a Listbox + + Utils._SetCalledSub("AddItem") + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvBox) Or IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvIndex) Then pvIndex = -1 + If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function + + AddItem = pvBox.AddItem(pvItem, pvIndex) + +Exit_Function: + Utils._ResetCalledSub("AddItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "AddItem", Erl) + AddItem = False + GoTo Exit_Function +End Function ' AddItem V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(Optional pvObject As Variant, ByVal Optional pvProperty As Variant) As Boolean +' Return True if pvObject has a valid property called pvProperty (case-insensitive comparison !) + +Dim vPropertiesList As Variant + + Utils._SetCalledSub("hasProperty") + If IsMissing(pvObject) Or IsMissing(pvProperty) Then Call _TraceArguments() + + hasProperty = False + If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _ + , OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _ + )) Then Goto Exit_Function + If Not Utils._CheckArgument(pvProperty, 2, vbString) Then Goto Exit_Function + + hasProperty = pvObject.hasProperty(pvProperty) + +Exit_Function: + Utils._ResetCalledSub("hasProperty") + Exit Function +End Function ' hasProperty V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move(Optional pvObject As Object _ + , ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ + , ByVal Optional pvWidth As Variant _ + , ByVal Optional pvHeight As Variant _ + ) As Variant +' Execute Move method + Utils._SetCalledSub("Move") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + Move = False + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + If IsMissing(pvLeft) Then Call _TraceArguments() + If IsMissing(pvTop) Then pvTop = -1 + If IsMissing(pvWidth) Then pvWidth = -1 + If IsMissing(pvHeight) Then pvHeight = -1 + + Move = pvObject.Move(pvLeft, pvTop, pvWidth, pvHeight) + +Exit_Function: + Utils._ResetCalledSub("Move") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Move", Erl) + GoTo Exit_Function +End Function ' Move V.0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenHelpFile() +' Open the help file from the Help menu (IDE only) +Const cstHelpFile = "http://www.access2base.com/access2base.html" + + On Local Error Resume Next + Call _ShellExecute(cstHelpFile) + +End Function ' OpenHelpFile V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperties As Variant, oCounter As Variant, opProperty As Variant +Dim vPropertiesList() As Variant + + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments() + Utils._SetCalledSub("Properties") + + Set vProperties = Nothing + If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _ + , OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _ + )) Then Goto Exit_Function + + If IsMissing(pvIndex) Then vProperties = pvObject.Properties Else vProperties = pvObject.Properties(pvIndex) + +Exit_Function: + Set Properties = vProperties + Utils._ResetCalledSub("Properties") + Exit Function +End Function ' Properties V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Refresh(Optional pvObject As Variant) As Boolean +' Refresh data with its most recent value in the database in a form or subform + Utils._SetCalledSub("Refresh") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + Refresh = False + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + + Refresh = pvObject.Refresh() + +Exit_Function: + Utils._ResetCalledSub("Refresh") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Refresh", Erl) + GoTo Exit_Function +End Function ' Refresh V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveItem(Optional pvBox As Variant,ByVal Optional pvIndex) As Boolean +' Remove an item from a Listbox +' Index may be a string value or an index-position + + Utils._SetCalledSub("RemoveItem") + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsMissing(pvBox) Or IsMissing(pvIndex) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function + + RemoveItem = pvBox.RemoveItem(pvIndex) + +Exit_Function: + Utils._ResetCalledSub("RemoveItem") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "RemoveItem", Erl) + RemoveItem = False + GoTo Exit_Function +End Function ' RemoveItem V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery(Optional pvObject As Variant) As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("Requery") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL, OBJSUBFORM)) Then Goto Exit_Function + + Requery = pvObject.Requery() + +Exit_Function: + Utils._ResetCalledSub("Requery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Requery", Erl) + GoTo Exit_Function +End Function ' Requery V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetFocus(Optional pvObject As Variant) As Boolean +' Execute SetFocus method + Utils._SetCalledSub("setFocus") + If IsMissing(pvObject) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL)) Then Goto Exit_Function + + SetFocus = pvObject.setFocus() + +Exit_Function: + Utils._ResetCalledSub("SetFocus") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SetFocus", Erl) + Goto Exit_Function +Error_Grid: + TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name)) + Goto Exit_Function +End Function ' SetFocus V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _OptionGroup(ByVal pvGroupName As Variant _ + , ByVal psParentType As String _ + , poComponent As Object _ + , poParent As Object _ + ) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name + + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + Set _OptionGroup = Nothing + + If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function + +Dim ogGroup As Variant, i As Integer, j As Integer, bFound As Boolean +Dim vOptionButtons() As Variant, sGroupName As String +Dim lXY() As Long, iIndex() As Integer ' Two indexes X-Y coordinates +Dim oView As Object, oDatabaseForm As Object, vControls As Variant + +Const cstPixels = 10 ' Tolerance on coordinates when drawn approximately + + bFound = False + Select Case psParentType + Case CTLPARENTISFORM + 'poParent is a forms collection, find the appropriate database form + For i = 0 To poParent.Count - 1 + Set oDatabaseForm = poParent.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + oDatabaseForm.getGroup(j, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For + End If + Next j + If bFound Then Exit For + End If + If bFound Then Exit For + Next i + Case CTLPARENTISSUBFORM + 'poParent is already a database form + Set oDatabaseForm = poParent + For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + oDatabaseForm.getGroup(j, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For + End If + Next j + End Select + + If bFound Then + + ogGroup = New Optiongroup + ogGroup._This = ogGroup + ogGroup._Name = sGroupName + ogGroup._ButtonsGroup = vOptionButtons + ogGroup._Count = UBound(vOptionButtons) + 1 + ogGroup._ParentType = psParentType + ogGroup._MainForm = oDatabaseForm.Name + Set ogGroup._ParentComponent = poComponent + + ReDim lXY(1, ogGroup._Count - 1) + ReDim iIndex(ogGroup._Count - 1) + For i = 0 To ogGroup._Count - 1 ' Find the position of each radiobutton + Set oView = poComponent.CurrentController.getControl(ogGroup._ButtonsGroup(i)) + lXY(0, i) = oView.PosSize.X + lXY(1, i) = oView.PosSize.Y + Next i + For i = 0 To ogGroup._Count - 1 ' Sort them on XY coordinates + If i = 0 Then + iIndex(0) = 0 + Else + iIndex(i) = i + For j = i - 1 To 0 Step -1 + If lXY(1, i) - lXY(1, j) < - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) <= cstPixels And lXY(0, i) - lXY(0, j) < - cstPixels ) Then + iIndex(i) = iIndex(j) + iIndex(j) = iIndex(j) + 1 + End If + Next j + End If + Next i + ogGroup._ButtonsIndex = iIndex() + + Set _OptionGroup = ogGroup + + Else + + Set _OptionGroup = Nothing + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName)) + + End If + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err,"_OptionGroup", Erl) + GoTo Exit_Function +End Function ' _OptionGroup V1.1.0 + + \ No newline at end of file diff --git a/wizards/source/access2base/Module.xba b/wizards/source/access2base/Module.xba new file mode 100644 index 000000000..d3095d645 --- /dev/null +++ b/wizards/source/access2base/Module.xba @@ -0,0 +1,722 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be MODULE +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Library As Object ' com.sun.star.container.XNameAccess +Private _LibraryName As String +Private _Storage As String ' GLOBAL or DOCUMENT +Private _Script As String ' Full script (string with vbLf's) +Private _Lines As Variant ' Array of script lines +Private _CountOfLines As Long +Private _ProcsParsed As Boolean ' To test before use of proc arrays +Private _ProcNames() As Variant ' All procedure names +Private _ProcDecPositions() As Variant ' All procedure declarations +Private _ProcEndPositions() As Variant ' All end procedure statements +Private _ProcTypes() As Variant ' One of the vbext_pk_* constants + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJMODULE + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + Set _Library = Nothing + _LibraryName = "" + _Storage = "" + _Script = "" + _Lines = Array() + _CountOfLines = 0 + _ProcsParsed = False + _ProcNames = Array() + _ProcDecPositions = Array() + _ProcEndPositions = Array() +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get CountOfDeclarationLines() As Long + CountOfDeclarationLines = _PropertyGet("CountOfDeclarationLines") +End Property ' CountOfDeclarationLines (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get CountOfLines() As Long + CountOfLines = _PropertyGet("CountOfLines") +End Property ' CountOfLines (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Lines(Optional ByVal pvLine As Variant, Optional ByVal pvNumLines As Variant) As String +' Returns a string containing the contents of a specified line or lines in a standard module or a class module + +Const cstThisSub = "Module.Lines" + Utils._SetCalledSub(cstThisSub) + +Dim sLines As String, lLine As Long + sLines = "" + + If IsMissing(pvLine) Or IsMissing(pvNumLines) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function + If Not Utils._CheckArgument(pvNumLines, 1, _AddNumeric()) Then GoTo Exit_Function + + lLine = pvLine + Do While lLine < _CountOfLines And lLine < pvLine + pvNumLines + sLines = sLines & _Lines(lLine - 1) & vbLf + lLine = lLine + 1 + Loop + If Len(sLines) > 0 Then sLines = Left(sLines, Len(sLines) - 1) + +Exit_Function: + Lines = sLines + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Lines + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ProcBodyLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long +' Return the number of the line at which the body of a specified procedure begins + +Const cstThisSub = "Module.ProcBodyLine" + Utils._SetCalledSub(cstThisSub) + +Dim iIndex As Integer + + If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function + If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function + + iIndex = _FindProcIndex(pvProc, pvProcType) + If iIndex >= 0 Then ProcBodyLine = _LineOfPosition(_ProcDecPositions(iIndex)) Else ProcBodyLine = iIndex + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ProcBodyline + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ProcCountLines(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long +' Return the number of lines in the specified procedure + +Const cstThisSub = "Module.ProcCountLines" + Utils._SetCalledSub(cstThisSub) + +Dim iIndex As Integer, lStart As Long, lEnd As Long + + If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function + If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function + + iIndex = _FindProcIndex(pvProc, pvProcType) + lStart = ProcStartLine(pvProc, pvProcType) + lEnd = _LineOfPosition(_ProcEndPositions(iIndex)) + ProcCountLines = lEnd - lStart + 1 + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ProcCountLines + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ProcOfLine(Optional ByVal pvLine As Variant, Optional ByRef pvProcType As Variant) As String +' Return the name and type of the procedure containing line pvLine + +Const cstThisSub = "Module.ProcOfLine" + Utils._SetCalledSub(cstThisSub) + +Dim sProcedure As String, iProc As Integer, lLineDec As Long, lLineEnd As Long + + If IsMissing(pvLine) Or IsMissing(pvProcType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function + If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function + + If Not _ProcsParsed Then _ParseProcs() + + sProcedure = "" + For iProc = 0 To UBound(_ProcNames) + lLineEnd = _LineOfPosition(_ProcEndPositions(iProc)) + If pvLine <= lLineEnd Then + lLineDec = _LineOfPosition(_ProcDecPositions(iProc)) + If pvLine < lLineDec Then ' Line between 2 procedures + sProcedure = "" + Else + sProcedure = _ProcNames(iProc) + pvProcType = _ProcTypes(iProc) + End If + Exit For + End If + Next iProc + +Exit_Function: + ProcOfLine = sProcedure + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ProcOfline + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ProcStartLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long +' Return the number of the line at which the specified procedure begins + +Const cstThisSub = "Module.ProcStartLine" + Utils._SetCalledSub(cstThisSub) + +Dim lLine As Long, lIndex As Long, sLine As String + + If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function + If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function + + lLine = ProcBodyLine(pvProc, pvProcType) + ' Search baclIndexward for comment lines + lIndex = lLine - 1 + Do While lIndex > 0 + sLine = _Trim(_Lines(lIndex - 1)) + If UCase(Left(sLine, 4)) = "REM " Or Left(sLine, 1) = "'" Then + lLine = lIndex + Else + Exit Do + End If + lIndex = lIndex - 1 + Loop + + ProcStartLine = lLine + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' ProcStartLine + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Const cstThisSub = "Module.Properties" + Utils._SetCalledSub(cstThisSub) + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get pType() As String + pType = _PropertyGet("Type") +End Property ' Type (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Find(Optional ByVal pvTarget As Variant _ + , Optional ByRef pvStartLine As Variant _ + , Optional ByRef pvStartColumn As Variant _ + , Optional ByRef pvEndLine As Variant _ + , Optional ByRef pvEndColumn As Variant _ + , Optional ByVal pvWholeWord As Boolean _ + , Optional ByVal pvMatchCase As Boolean _ + , Optional ByVal pvPatternSearch As Boolean _ + ) As Boolean +' Finds specified text in the module +' xxLine and xxColumn arguments are mainly to return the position of the found string +' If they are initialized but nonsense, the function returns False + +Const cstThisSub = "Module.Find" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim bFound As Boolean, lPosition As Long, lStartLine As Long, lStartColumn As Long, lStartPosition As Long +Dim lEndLine As Long, lEndColumn As Long, lEndPosition As Long +Dim sMatch As String, vOptions As Variant, sPattern As String +Dim i As Integer, sSpecChar As String + +Const cstSpecialCharacters = "\[^$.|?*+()" + + bFound = False + + If IsMissing(pvTarget) Or IsMissing(pvStartLine) Or IsMissing(pvStartColumn) Or IsMissing(pvEndLine) Or IsMissing(pvEndColumn) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvTarget, 1, vbString) Then GoTo Exit_Function + If Len(pvTarget) = 0 Then GoTo Exit_Function + If Not IsEmpty(pvStartLine) Then + If Not Utils._CheckArgument(pvStartLine, 2, _AddNumeric()) Then GoTo Exit_Function + End If + If Not IsEmpty(pvStartColumn) Then + If Not Utils._CheckArgument(pvStartColumn, 3, _AddNumeric()) Then GoTo Exit_Function + End If + If Not IsEmpty(pvEndLine) Then + If Not Utils._CheckArgument(pvEndLine, 4, _AddNumeric()) Then GoTo Exit_Function + End If + If Not IsEmpty(pvEndColumn) Then + If Not Utils._CheckArgument(pvEndColumn, 5, _AddNumeric()) Then GoTo Exit_Function + End If + If IsMissing(pvWholeWord) Then pvWholeWord = False + If Not Utils._CheckArgument(pvWholeWord, 6, vbBoolean) Then GoTo Exit_Function + If IsMissing(pvMatchCase) Then pvMatchCase = False + If Not Utils._CheckArgument(pvMatchCase, 7, vbBoolean) Then GoTo Exit_Function + If IsMissing(pvPatternSearch) Then pvPatternSearch = False + If Not Utils._CheckArgument(pvPatternSearch, 8, vbBoolean) Then GoTo Exit_Function + + ' Initialize starting values + If IsEmpty(pvStartLine) Then lStartLine = 1 Else lStartLine = pvStartLine + If lStartLine <= 0 Or lStartLine > UBound(_Lines) + 1 Then GoTo Exit_Function + If IsEmpty(pvStartColumn) Then lStartColumn = 1 Else lStartColumn = pvStartColumn + If lStartColumn <= 0 Then GoTo Exit_Function + If lStartColumn > 1 And lStartColumn > Len(_Lines(lStartLine + 1)) Then GoTo Exit_Function + lStartPosition = _PositionOfLine(lStartline) + lStartColumn - 1 + If IsEmpty(pvEndLine) Then lEndLine = UBound(_Lines) + 1 Else lEndLine = pvEndLine + If lEndLine < lStartLine Or lEndLine > UBound(_Lines) + 1 Then GoTo Exit_Function + If IsEmpty(pvEndColumn) Then lEndColumn = Len(_Lines(lEndLine - 1)) Else lEndColumn = pvEndColumn + If lEndColumn < 0 Then GoTo Exit_Function + If lEndColumn = 0 Then lEndColumn = 1 + If lEndColumn > Len(_Lines(lEndLine - 1)) + 1 Then GoTo Exit_Function + lEndPosition = _PositionOfLine(lEndline) + lEndColumn - 1 + + If pvMatchCase Then + Set vOptions = _A2B_.SearchOptions + vOptions.transliterateFlags = 0 + End If + + ' Define pattern to search for + sPattern = pvTarget + ' Protect special characters in regular expressions + For i = 1 To Len(cstSpecialCharacters) + sSpecChar = Mid(cstSpecialCharacters, i, 1) + sPattern = Replace(sPattern, sSpecChar, "\" & sSpecChar) + Next i + If pvPatternSearch Then sPattern = Replace(Replace(sPattern, "\*", ".*"), "\?", ".") + If pvWholeWord Then sPattern = "\b" & sPattern & "\b" + + lPosition = lStartPosition + sMatch = Utils._RegexSearch(_Script, sPattern, lPosition) + ' Re-establish default options for later searches + If pvMatchCase Then vOptions.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE + + ' Found within requested bounds ? + If sMatch <> "" And lPosition >= lStartPosition And lPosition <= lEndPosition Then + pvStartLine = _LineOfPosition(lPosition) + pvStartColumn = lPosition - _PositionOfLine(pvStartLine) + 1 + pvEndLine = _LineOfPosition(lPosition + Len(sMatch) - 1) + If pvEndLine > pvStartLine Then + pvEndColumn = lPosition + Len(sMatch) - 1 - _PositionOfLine(pvEndLine) + Else + pvEndColumn = pvStartColumn + Len(sMatch) - 1 + End If + bFound = True + End If + +Exit_Function: + Find = bFound + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Module.Find", Erl) + bFound = False + GoTo Exit_Function +End Function ' Find + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Const cstThisSub = "Module.Properties" + + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM --------------------------------Mid(a._Script, iCtl, 25)--------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + +Const cstThisSub = "Module.hasProperty" + + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Utils._ResetCalledSub(cstThisSub) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _BeginStatement(ByVal plStart As Long) As Long +' Return the position in _Script of the beginning of the current statement as defined by plStart + +Dim sProc As String, iProc As Integer, iType As Integer +Dim lPosition As Long, lPrevious As Long, sFind As String + + sProc = ProcOfLine(_LineOfPosition(plStart), iType) + iProc = _FindProcIndex(sProc, iType) + If iProc < 0 Then lPosition = 1 Else lPosition = _ProcDecPositions(iProc) + + sFind = "Any" + Do While lPosition < plStart And sFind <> "" + lPrevious = lPosition + sFind = _FindPattern("%^\w", lPosition) + If sFind = "" Then Exit Do + Loop + + _BeginStatement = lPrevious + +End Function ' _EndStatement + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _EndStatement(ByVal plStart As Long) As Long +' Return the position in _Script of the end of the current statement as defined by plStart +' plStart is assumed not to be in the middle of a comment or a string + +Dim sMatch As String, lPosition As Long + lPosition = plStart + sMatch = _FindPattern("%$", lPosition) + _EndStatement = lPosition + +End Function ' _EndStatement + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _FindPattern(ByVal psPattern As Variant, Optional ByRef plStart As Long) As String +' Find first occurrence of any of the patterns in |-delimited string psPattern +' Special escapes +' - for word breaks: "%B" (f.i. for searching "END%BFUNCTION") +' - for statement start: "%^" (f.i. for searching "%^END%BFUNCTION"). Necessarily first 2 characters of pattern +' - for statement end: "%$". Pattern should not contain anything else +' If quoted string searched, pattern should start and end with a double quote +' Return "" if none found, otherwise returns the matching string +' plStart = start position of _Script to search (starts at 1) +' In output plStart contains the first position of the matching string or is left unchanged +' To search again the same or another pattern => plStart = plStart + Len(matching string) +' Comments and strings are skipped + +' Common patterns +Const cstComment = "('|\bREM\b)[^\n]*$" +Const cstString = """[^""\n]*""" +Const cstBeginStatement = "(^|:|\bthen\b|\belse\b|\n)[ \t]*" +Const cstEndStatement = "[ \t]*($|:|\bthen\b|\belse\b|\n)" +Const cstContinuation = "[ \t]_\n" +Const cstWordBreak = "\b[ \t]+(_\n[ \t]*)?\b" +Const cstAlt = "|" + +Dim sRegex As String, lStart As Long, bContinue As Boolean, sMatch As String +Dim bEndStatement As Boolean, bQuote As Boolean + + If psPattern = "%$" Then + sRegex = cstEndStatement + Else + sRegex = psPattern + If Left(psPattern, 2) = "%^" Then sRegex = cstBeginStatement & Right(sRegex, Len(sregex) - 2) + sregex = Replace(sregex, "%B", cstWordBreak) + End If + ' Add all to ignore patterns to regex. If pattern = quoted string do not add cstString + If Len(psPattern) > 2 And Left(psPattern, 1) = """" And Right(psPattern, 1) = """" Then + bQuote = True + sRegex = sRegex & cstAlt & cstComment & cstAlt & cstContinuation + Else + bQuote = False + sRegex = sRegex & cstAlt & cstComment & cstAlt & cstString & cstAlt & cstContinuation + End If + + If IsMissing(plStart) Then plStart = 1 + lStart = plStart + + bContinue = True + Do While bContinue + bEndStatement = False + sMatch = Utils._RegexSearch(_Script, sRegex, lStart) + Select Case True + Case sMatch = "" + bContinue = False + Case Left(sMatch, 1) = "'" + bEndStatement = True + Case Left(sMatch, 1) = """" + If bQuote Then + plStart = lStart + bContinue = False + End If + Case Left(smatch, 1) = ":" Or Left(sMatch, 1) = vbLf + If psPattern = "%$" Then + bEndStatement = True + Else + bContinue = False + plStart = lStart + 1 + sMatch = Right(sMatch, Len(sMatch) - 1) + End If + Case UCase(Left(sMatch, 4)) = "REM " Or UCase(Left(sMatch, 4)) = "REM" & vbTab Or UCase(Left(sMatch, 4)) = "REM" & vbNewLine + bEndStatement = True + Case UCase(Left(sMatch, 4)) = "THEN" Or UCase(Left(sMatch, 4)) = "ELSE" + If psPattern = "%$" Then + bEndStatement = True + Else + bContinue = False + plStart = lStart + 4 + sMatch = Right(sMatch, Len(sMatch) - 4) + End If + Case sMatch = " _" & vbLf + Case Else ' Found + plStart = lStart + bContinue = False + End Select + If bEndStatement And psPattern = "%$" Then + bContinue = False + plStart = lStart - 1 + sMatch = "" + End If + lStart = lStart + Len(sMatch) + Loop + + _FindPattern = sMatch + +End Function ' _FindPattern + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _FindProcIndex(ByVal psProc As String, ByVal piType As Integer) As Integer +' Return index of entry in _Procnames corresponding with pvProc + +Dim i As Integer, iIndex As Integer + + If Not _ProcsParsed Then _ParseProcs + + iIndex = -1 + For i = 0 To UBound(_ProcNames) + If UCase(psProc) = UCase(_ProcNames(i)) And piType = _ProcTypes(i) Then + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, Utils._CalledSub(), 0, , Array(psProc, _Name)) + +Exit_Function: + _FindProcIndex = iIndex + Exit Function +End Function ' _FindProcIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize() + + _Script = Replace(_Script, vbCr, "") + _Lines = Split(_Script, vbLf) + _CountOfLines = UBound(_Lines) + 1 + +End Sub ' _Initialize + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _LineOfPosition(ByVal plPosition) As Long +' Return the line number of a position in _Script + +Dim lLine As Long, lLength As Long + ' Start counting from start or end depending on how close position is + If plPosition <= Len(_Script) / 2 Then + lLength = 0 + For lLine = 0 To UBound(_Lines) + lLength = lLength + Len(_Lines(lLine)) + 1 ' + 1 for line feed + If lLength >= plPosition Then + _LineOfPosition = lLine + 1 + Exit Function + End If + Next lLine + Else + If Right(_Script, 1) = vbLf Then lLength = Len(_Script) + 1 Else lLength = Len(_Script) + For lLine = UBound(_Lines) To 0 Step -1 + lLength = lLength - Len(_Lines(lLine)) - 1 ' - 1 for line feed + If lLength <= plPosition Then + _LineOfPosition = lLine + 1 + Exit Function + End If + Next lLine + End If + +End Function ' _LineOfPosition + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub _ParseProcs() +' Fills the Proc arrays: name, start and end position +' Executed at first request needing this processing + +Dim lPosition As Long, iProc As Integer, sDecProc As String, sEndProc As String, sNameProc As String, sType As String +Const cstDeclaration = "%^(private%B|public%B)?\b(property%Bget|property%Blet|property%Bset|function|sub)\b" +Const cstEnd = "%^end%B(property|function|sub)\b" +Const cstName = "\w*" '"[A-Za-z_][A-Za-z_0-9]*" + + If _ProcsParsed Then Exit Sub ' Do not redo if already done + _ProcNames = Array() + _ProcDecPositions = Array() + _ProcEndPositions = Array() + _ProcTypes = Array() + + lPosition = 1 + iProc = -1 + sDecProc = "???" + Do While sDecProc <> "" + ' Identify Function/Sub declaration string + sDecProc = _FindPattern(cstDeclaration, lPosition) + If sDecProc <> "" Then + iProc = iProc + 1 + ReDim Preserve _ProcNames(0 To iProc) + ReDim Preserve _ProcDecPositions(0 To iProc) + ReDim Preserve _ProcEndPositions(0 To iProc) + ReDim Preserve _ProcTypes(0 To iProc) + _ProcDecPositions(iProc) = lPosition + lPosition = lPosition + Len(sDecProc) + ' Identify procedure type + Select Case True + Case InStr(UCase(sDecProc), "FUNCTION") > 0 : _ProcTypes(iProc) = vbext_pk_Proc + Case InStr(UCase(sDecProc), "SUB") > 0 : _ProcTypes(iProc) = vbext_pk_Proc + Case InStr(UCase(sDecProc), "GET") > 0 : _ProcTypes(iProc) = vbext_pk_Get + Case InStr(UCase(sDecProc), "LET") > 0 : _ProcTypes(iProc) = vbext_pk_Let + Case InStr(UCase(sDecProc), "SET") > 0 : _ProcTypes(iProc) = vbext_pk_Set + End Select + ' Identify name of Function/Sub + sNameProc = _FindPattern(cstName, lPosition) + If sNameProc = "" Then Exit Do ' Should never happen + _ProcNames(iProc) = sNameProc + lPosition = lPosition + Len(sNameProc) + ' Identify End statement + sEndProc = _FindPattern(cstEnd, lPosition) + If sEndProc = "" Then Exit Do ' Should never happen + _ProcEndPositions(iProc) = lPosition + lPosition = lPosition + Len(sEndProc) + End If + Loop + + _ProcsParsed = True + +End Sub + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PositionOfLine(ByVal plLine) As Long +' Return the position of the first character of the given line in _Script + +Dim lLine As Long, lPosition As Long + ' Start counting from start or end depending on how close line is + If plLine <= (UBound(_Lines) + 1) / 2 Then + lPosition = 0 + For lLine = 0 To plLine - 1 + lPosition = lPosition + 1 ' + 1 for line feed + If lLine < plLine - 1 Then lPosition = lPosition + Len(_Lines(lLine)) + Next lLine + Else + lPosition = Len(_Script) + 2 ' Anticipate an ending null-string and a line feed + For lLine = UBound(_Lines) To plLine - 1 Step -1 + lPosition = lPosition - Len(_Lines(lLine)) - 1 ' - 1 for line feed + Next lLine + End If + + _PositionOfLine = lPosition + +End Function ' _LineOfPosition + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("CountOfDeclarationLines", "CountOfLines", "Name", "ObjectType", "Type") + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + +Dim cstThisSub As String +Const cstDot = "." + +Dim sText As String + + If _ErrorHandler() Then On Local Error Goto Error_Function + cstThisSub = "Module.get" & psProperty + Utils._SetCalledSub(cstThisSub) + _PropertyGet = Null + + Select Case UCase(psProperty) + Case UCase("CountOfDeclarationLines") + If Not _ProcsParsed Then _ParseProcs() + If UBound(_ProcNames) >= 0 Then + _PropertyGet = ProcStartLine(_ProcNames(0), _ProcTypes(0)) - 1 + Else + _PropertyGet = _CountOfLines + End If + Case UCase("CountOfLines") + _PropertyGet = _CountOfLines + Case UCase("Name") + _PropertyGet = _Storage & cstDot & _LibraryName & cstDot & _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Type") + ' Find option statement before any procedure declaration + sText = _FindPattern("%^option%Bclassmodule\b|\bfunction\b|\bsub\b|\bproperty\b") + If UCase(Left(sText, 6)) = "OPTION" Then _PropertyGet = acClassModule Else _PropertyGet = acStandardModule + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Module._PropertyGet", Erl) + _PropertyGet = Null + GoTo Exit_Function +End Function ' _PropertyGet + + \ No newline at end of file diff --git a/wizards/source/access2base/OptionGroup.xba b/wizards/source/access2base/OptionGroup.xba new file mode 100644 index 000000000..f4b749ef6 --- /dev/null +++ b/wizards/source/access2base/OptionGroup.xba @@ -0,0 +1,315 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be FORM +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _ParentType As String +Private _ParentComponent As Object +Private _MainForm As String +Private _DocEntry As Integer +Private _DbEntry As Integer +Private _ButtonsGroup() As Variant +Private _ButtonsIndex() As Variant +Private _Count As Long + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJOPTIONGROUP + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _ParentType = "" + _ParentComponent = Nothing + _DocEntry = -1 + _DbEntry = -1 + _ButtonsGroup = Array() + _ButtonsIndex = Array() + _Count = 0 +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Count() As Variant + Count = _PropertyGet("Count") +End Property ' Count (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("OptionGroup.Controls") + +Dim ocControl As Variant, iArgNr As Integer, i As Integer +Dim oCounter As Object + + Set ocControl = Nothing + + If IsMissing(pvIndex) Then ' No argument, return Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + oCounter._Count = _Count + Set Controls = oCounter + Goto Exit_Function + End If + + If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2 + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < 0 Or pvIndex > _Count - 1 Then Goto Trace_Error_Index + + ' Start building the ocControl object + ' Determine exact name + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISGROUP + + ocControl._Shortcut = "" + For i = 0 To _Count - 1 + If _ButtonsIndex(i) = pvIndex Then + Set ocControl.ControlModel = _ButtonsGroup(i) + Select Case _ParentType + Case CTLPARENTISDIALOG : ocControl._Name = _ButtonsGroup(i).Name + Case Else : ocControl._Name = _Name ' OptionGroup and individual radio buttons share the same name + End Select + ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() + Exit For + End If + Next i + ocControl._FormComponent = _ParentComponent + ocControl._ClassId = acRadioButton + Select Case _ParentType + Case CTLPARENTISDIALOG : Set ocControl.ControlView = _ParentComponent.getControl(ocControl._Name) + Case Else : Set ocControl.ControlView = _ParentComponent.CurrentController.getControl(ocControl.ControlModel) + End Select + + ocControl._Initialize() + ocControl._DocEntry = _DocEntry + ocControl._DbEntry = _DbEntry + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("OptionGroup.Controls") + Exit Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "OptionGroup.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("OptionGroup.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("OptionGroup.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("OptionGroup.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("OptionGroup.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("Count", "Name", "ObjectType", "Value") + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("OptionGroup.get" & psProperty) + +'Execute +Dim oDatabase As Object, vBookmark As Variant +Dim iValue As Integer, i As Integer + _PropertyGet = EMPTY + Select Case UCase(psProperty) + Case UCase("Count") + _PropertyGet = _Count + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + iValue = -1 + For i = 0 To _Count - 1 ' Find the selected RadioButton + If _ButtonsGroup(i).State = 1 Then + iValue = _ButtonsIndex(i) + Exit For + End If + Next i + _PropertyGet = iValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("OptionGroup.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "OptionGroup._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("OptionGroup.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim i As Integer, iRadioIndex As Integer, oModel As Object, iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("Value") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Or pvValue > _Count - 1 Then Goto Trace_Error_Value + For i = 0 To _Count - 1 + _ButtonsGroup(i).State = 0 + If _ButtonsIndex(i) = pvValue Then iRadioIndex = i + Next i + _ButtonsGroup(iRadioIndex).State = 1 + Set oModel = _ButtonsGroup(iRadioIndex) + If Utils._hasUNOProperty(oModel, "DataField") Then + If Not IsNull(oModel.Datafield) And Not IsEmpty(oModel.Datafield) Then + If oModel.Datafield <> "" And Utils._hasUNOMethod(oModel, "commit") Then oModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM] + End If + End If + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("OptionGroup.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "OptionGroup._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/PropertiesGet.xba b/wizards/source/access2base/PropertiesGet.xba new file mode 100644 index 000000000..59fc8db31 --- /dev/null +++ b/wizards/source/access2base/PropertiesGet.xba @@ -0,0 +1,1120 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAbsolutePosition(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAbsolutePosition") + getAbsolutePosition = PropertiesGet._getProperty(pvObject, "AbsolutePosition") +End Function ' getAbsolutePosition + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAllowAdditions(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowAdditions") + getAllowAdditions = PropertiesGet._getProperty(pvObject, "AllowAdditions") +End Function ' getAllowAdditions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAllowDeletions(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowDeletions") + getAllowDeletions = PropertiesGet._getProperty(pvObject, "AllowDeletions") +End Function ' getAllowDeletions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getAllowEdits(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowEdits") + getAllowEdits = PropertiesGet._getProperty(pvObject, "AllowEdits") +End Function ' getAllowEdits + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBackColor(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBackColor") + getBackColor = PropertiesGet._getProperty(pvObject, "BackColor") +End Function ' getBackColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBeginGroup(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBeginGroup") + getBeginGroup = PropertiesGet._getProperty(pvObject, "BeginGroup") +End Function ' getBeginGroup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBOF(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBOF") + getBOF = PropertiesGet._getProperty(pvObject, "BOF") +End Function ' getBOF + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBookmark(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBookmark") + getBookmark = PropertiesGet._getProperty(pvObject, "Bookmark") +End Function ' getBookmark + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBookmarkable(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBookmarkable") + getBookmarkable = PropertiesGet._getProperty(pvObject, "Bookmarkable") +End Function ' getBookmarkable + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBorderColor(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBorderColor") + getBorderColor = PropertiesGet._getProperty(pvObject, "BorderColor") +End Function ' getBorderColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBorderStyle(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBorderStyle") + getBorderStyle = PropertiesGet._getProperty(pvObject, "BorderStyle") +End Function ' getBorderStyle + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getBuiltIn(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBuiltIn") + getBuiltIn = PropertiesGet._getProperty(pvObject, "BuiltIn") +End Function ' getBuiltIn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getButtonLeft(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonLeft") + getButtonLeft = PropertiesGet._getProperty(pvObject, "ButtonLeft") +End Function ' getButtonLeft + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getButtonMiddle(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonMiddle") + getButtonMiddle = PropertiesGet._getProperty(pvObject, "ButtonMiddle") +End Function ' getButtonMiddle + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getButtonRight(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonRight") + getButtonRight = PropertiesGet._getProperty(pvObject, "ButtonRight") +End Function ' getButtonRight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCancel(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCancel") + getCancel = PropertiesGet._getProperty(pvObject, "Cancel") +End Function ' getCancel + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCaption(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCaption") + getCaption = PropertiesGet._getProperty(pvObject, "Caption") +End Function ' getCaption + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getClickCount(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getClickCount") + getClickCount = PropertiesGet._getProperty(pvObject, "ClickCount") +End Function ' getClickCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getContextShortcut(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getContextShortcut") + getContextShortcut = PropertiesGet._getProperty(pvObject, "ContextShortcut") +End Function ' getContextShortcut + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getControlSource(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlSource") + getControlSource = PropertiesGet._getProperty(pvObject, "ControlSource") +End Function ' getControlSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getControlTipText(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlTipText") + getControlTipText = PropertiesGet._getProperty(pvObject, "ControlTipText") +End Function ' getControlTipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getControlType(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlType") + getControlType = PropertiesGet._getProperty(pvObject, "ControlType") +End Function ' getControlType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCount(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCount") + getCount = PropertiesGet._getProperty(pvObject, "Count") +End Function ' getCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getCurrentRecord(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCurrentRecord") + getCurrentRecord = PropertiesGet._getProperty(pvObject, "CurrentRecord") +End Function ' getCurrentRecord + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDataType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDataType") + getDataType = PropertiesGet._getProperty(pvObject, "DataType") +End Function ' getDataType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDbType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDbType") + getDbType = PropertiesGet._getProperty(pvObject, "DbType") +End Function ' getDbType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDefault(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDefault") + getDefault = PropertiesGet._getProperty(pvObject, "Default") +End Function ' getDefault + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDefaultValue(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDefaultValue") + getDefaultValue = PropertiesGet._getProperty(pvObject, "DefaultValue") +End Function ' getDefaultValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getDescription(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDescription") + getDescription = PropertiesGet._getProperty(pvObject, "Description") +End Function ' getDescription + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEditMode(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEditMode") + getEditMode = PropertiesGet._getProperty(pvObject, "EditMode") +End Function ' getEditMode + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEnabled(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEnabled") + getEnabled = PropertiesGet._getProperty(pvObject, "Enabled") +End Function ' getEnabled + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEOF(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEOF") + getEOF = PropertiesGet._getProperty(pvObject, "EOF") +End Function ' getEOF + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEventName(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEventName") + getEventName = PropertiesGet._getProperty(pvObject, "EventName") +End Function ' getEventName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getEventType(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEventType") + getEventType = PropertiesGet._getProperty(pvObject, "EventType") +End Function ' getEventType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFieldSize(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFieldSize") + getFieldSize = PropertiesGet._getProperty(pvObject, "FieldSize") +End Function ' getFieldSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFilter(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFilter") + getFilter = PropertiesGet._getProperty(pvObject, "Filter") +End Function ' getFilter + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFilterOn(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFilterOn") + getFilterOn = PropertiesGet._getProperty(pvObject, "FilterOn") +End Function ' getFilterOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFocusChangeTemporary(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFocusChangeTemporary") + getFocusChangeTemporary = PropertiesGet._getProperty(pvObject, "FocusChangeTemporary") +End Function ' getFocusChangeTemporary + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontBold(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontBold") + getFontBold = PropertiesGet._getProperty(pvObject, "FontBold") +End Function ' getFontBold + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontItalic(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontItalic") + getFontItalic = PropertiesGet._getProperty(pvObject, "FontItalic") +End Function ' getFontItalic + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontName(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontName") + getFontName = PropertiesGet._getProperty(pvObject, "FontName") +End Function ' getFontName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontSize(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontSize") + getFontSize = PropertiesGet._getProperty(pvObject, "FontSize") +End Function ' getFontSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontUnderline(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontUnderline") + getFontUnderline = PropertiesGet._getProperty(pvObject, "FontUnderline") +End Function ' getFontUnderline + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFontWeight(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontWeight") + getFontWeight = PropertiesGet._getProperty(pvObject, "FontWeight") +End Function ' getFontWeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getForm(Optional pvObject As Variant) As Variant ' Return Subform pseudo + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getForm") + getForm = PropertiesGet._getProperty(pvObject, "Form") +End Function ' getForm + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getFormat(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFormat") + getFormat = PropertiesGet._getProperty(pvObject, "Format") +End Function ' getFormat + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getHeight(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getHeight") + getHeight = PropertiesGet._getProperty(pvObject, "Height") +End Function ' getHeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getForeColor(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getForeColor") + getForeColor = PropertiesGet._getProperty(pvObject, "ForeColor") +End Function ' getForeColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getIsLoaded(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getIsLoaded") + getIsLoaded = PropertiesGet._getProperty(pvObject, "IsLoaded") +End Function ' getIsLoaded + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getItemData(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getItemData") + If IsMissing(pvIndex) Then + getItemData = PropertiesGet._getProperty(pvObject, "ItemData") + Else + getItemData = PropertiesGet._getProperty(pvObject, "ItemData", pvIndex) + End If +End Function ' getItemData + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyAlt(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyAlt") + getKeyAlt = PropertiesGet._getProperty(pvObject, "KeyAlt") +End Function ' getKeyAlt + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyChar(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyChar") + getKeyChar = PropertiesGet._getProperty(pvObject, "KeyChar") +End Function ' getKeyChar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyCode(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyCode") + getKeyCode = PropertiesGet._getProperty(pvObject, "KeyCode") +End Function ' getKeyCode + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyCtrl(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyCtrl") + getKeyCtrl = PropertiesGet._getProperty(pvObject, "KeyCtrl") +End Function ' getKeyCtrl + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyFunction(Optional pvObject As Variant) As Integer + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyFunction") + getKeyFunction = PropertiesGet._getProperty(pvObject, "KeyFunction") +End Function ' getKeyFunction + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getKeyShift(pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyShift") + getKeyShift = PropertiesGet._getProperty(pvObject, "KeyShift") +End Function ' getKeyShift + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getLinkChildFields(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLinkChildFields") + If IsMissing(pvObject) Then + getLinkChildFields = PropertiesGet._getProperty(pvObject, "LinkChildFields") + Else + getLinkChildFields = PropertiesGet._getProperty(pvObject, "LinkChildFields", pvIndex) + End If +End Function ' getLinkChildFields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getLinkMasterFields(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLinkMasterFields") + If IsMissing(pvIndex) Then + getLinkMasterFields = PropertiesGet._getProperty(pvObject, "LinkMasterFields") + Else + getLinkMasterFields = PropertiesGet._getProperty(pvObject, "LinkMasterFields", pvIndex) + End If +End Function ' getLinkMasterFields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getListCount(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getListCount") + getListCount = PropertiesGet._getProperty(pvObject, "ListCount") +End Function ' getListCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getListIndex(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getListIndex") + getListIndex = PropertiesGet._getProperty(pvObject, "ListIndex") +End Function ' getListIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getLocked(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLocked") + getLocked = PropertiesGet._getProperty(pvObject, "Locked") +End Function ' getLocked + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getMultiSelect(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getMultiSelect") + getMultiSelect = PropertiesGet._getProperty(pvObject, "MultiSelect") +End Function ' getMultiSelect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getName(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getName") + getName = PropertiesGet._getProperty(pvObject, "Name") +End Function ' getName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getObjectType(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getObjectType") + getObjectType = PropertiesGet._getProperty(pvObject, "ObjectType") +End Function ' getObjectType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOpenArgs(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOpenArgs") + getOpenArgs = PropertiesGet._getProperty(pvObject, "OpenArgs") +End Function ' getOpenArgs + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOptionGroup(Optional pvObject As Variant, pvName As variant) As Variant +' Return an OptionGroup object based on its name + + Utils._SetCalledSub("getOptionGroup") + If IsMissing(pvObject) Or IsMissing(pvName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvName, 2, vbString) Then Goto Exit_Function + + getOptionGroup = pvObject.OptionGroup(pvName) + +Exit_Function: + Utils._ResetCalledSub("getOptionGroup") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "getOptionGroup", Erl) + GoTo Exit_Function +End Function ' getOptionGroup V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOptionValue(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOptionValue") + getOptionValue = PropertiesGet._getProperty(pvObject, "OptionValue") +End Function ' getOptionValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOrderBy(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOrderBy") + getOrderBy = PropertiesGet._getProperty(pvObject, "OrderBy") +End Function ' getOrderBy + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getOrderByOn(Optional pvObject As Variant) As Boolean + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOrderByOn") + getOrderByOn = PropertiesGet._getProperty(pvObject, "OrderByOn") +End Function ' getOrderByOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getPage(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getPage") + getPage = PropertiesGet._getProperty(pvObject, "Page") +End Function ' getPage V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getParent(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getParent") + getParent = PropertiesGet._getProperty(pvObject, "Parent") +End Function ' getParent V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional pvItem As Variant, Optional ByVal pvProperty As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return property value of object pvItem, and psProperty property name + Utils._SetCalledSub("getProperty") + If IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvProperty) Then Call _TraceArguments() + If IsMissing(pvIndex) Then getProperty = PropertiesGet._getProperty(pvItem, pvProperty) Else getProperty = PropertiesGet._getProperty(pvItem, pvProperty, pvIndex) + Utils._ResetCalledSub("getProperty") +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecommendation(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecommendation") + getRecommendation = PropertiesGet._getProperty(pvObject, "Recommendation") +End Function ' getRecommendation + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecordCount(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordCount") + getRecordCount = PropertiesGet._getProperty(pvObject, "RecordCount") +End Function ' getRecordCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecordset(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordset") + getRecordset = PropertiesGet._getProperty(pvObject, "Recordset") +End Function ' getRecordset V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRecordSource(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordSource") + getRecordSource = PropertiesGet._getProperty(pvObject, "RecordSource") +End Function ' getRecordSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRequired(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRequired") + getRequired = PropertiesGet._getProperty(pvObject, "Required") +End Function ' getRequired + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRowChangeAction(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowChangeAction") + getRowChangeAction = PropertiesGet._getProperty(pvObject, "RowChangeAction") +End Function ' getRowChangeAction + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRowSource(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowSource") + getRowSource = PropertiesGet._getProperty(pvObject, "RowSource") +End Function ' getRowSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getRowSourceType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowSourceType") + getRowSourceType = PropertiesGet._getProperty(pvObject, "RowSourceType") +End Function ' getRowSourceType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSelected(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSelected") + If IsMissing(pvIndex) Then + getSelected = PropertiesGet._getProperty(pvObject, "Selected") + Else + getSelected = PropertiesGet._getProperty(pvObject, "Selected", pvIndex) + End If +End Function ' getSelected + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSize(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSize") + getSize = PropertiesGet._getProperty(pvObject, "Size") +End Function ' getSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSource(Optional pvObject As Variant) As String + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSource") + getSource = PropertiesGet._getProperty(pvObject, "Source") +End Function ' getSource V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSourceField(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSourceField") + getSourceField = PropertiesGet._getProperty(pvObject, "SourceField") +End Function ' getSourceField + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSourceTable(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSourceTable") + getSourceTable = PropertiesGet._getProperty(pvObject, "SourceTable") +End Function ' getSourceTable + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSpecialEffect(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSpecialEffect") + getSpecialEffect = PropertiesGet._getProperty(pvObject, "SpecialEffect") +End Function ' getSpecialEffect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSubType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubType") + getSubType = PropertiesGet._getProperty(pvObject, "SubType") +End Function ' getSubType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSubComponentName(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubComponentName") + getSubComponentName = PropertiesGet._getProperty(pvObject, "SubComponentName") +End Function ' getSubComponentName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getSubComponentType(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubComponentType") + getSubComponentType = PropertiesGet._getProperty(pvObject, "SubComponentType") +End Function ' getSubComponentType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTabIndex(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTabIndex") + getTabIndex = PropertiesGet._getProperty(pvObject, "TabIndex") +End Function ' getTabIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTabStop(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTabStop") + getTabStop = PropertiesGet._getProperty(pvObject, "TabStop") +End Function ' getTabStop + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTag(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTag") + getTag = PropertiesGet._getProperty(pvObject, "Tag") +End Function ' getTag + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getText(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getText") + getText = PropertiesGet._getProperty(pvObject, "Text") +End Function ' getText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTextAlign(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTextAlign") + getTextAlign = PropertiesGet._getProperty(pvObject, "TextAlign") +End Function ' getTextAlign + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTooltipText(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTooltipText") + getTooltipText = PropertiesGet._getProperty(pvObject, "TooltipText") +End Function ' getTooltipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTripleState(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTripleState") + getTripleState = PropertiesGet._getProperty(pvObject, "TripleState") +End Function ' getTripleState + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getTypeName(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTypeName") + getTypeName = PropertiesGet._getProperty(pvObject, "TypeName") +End Function ' getTypeName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getVisible(Optional pvObject As Variant) As Variant + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getVisible") + getVisible = PropertiesGet._getProperty(pvObject, "Visible") +End Function ' getVisible + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getWidth(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getWdth") + getWidth = PropertiesGet._getProperty(pvObject, "Width") +End Function ' getWidth + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getXPos(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getXPos") + getXPos = PropertiesGet._getProperty(pvObject, "XPos") +End Function ' getXPos + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getYPos(Optional pvObject As Variant) As Long + If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getYPos") + getYPos = PropertiesGet._getProperty(pvObject, "YPos") +End Function ' getYPos + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _getProperty(pvItem As Variant, ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant +' Return property value of the psProperty property name within object pvItem + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("get" & psProperty) + _getProperty = Nothing + +'pvItem must be an object and have the requested property + If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function + If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error +'Check Index argument + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 3, Utils._AddNumeric()) Then Goto Exit_Function + End If +'Execute + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.AbsolutePosition + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.AllowAdditions + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.AllowDeletions + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.AllowEdits + Case UCase("BackColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BackColor + Case UCase("BeginGroup") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BeginGroup + Case UCase("BOF") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.BOF + Case UCase("Bookmark") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function + _getProperty = pvItem.Bookmark + Case UCase("Bookmarkable") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.Bookmarkable + Case UCase("BorderColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BorderColor + Case UCase("BorderStyle") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.BorderStyle + Case UCase("BuiltIn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.BuiltIn + Case UCase("ButtonLeft") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ButtonLeft + Case UCase("ButtonMiddle") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ButtonMiddle + Case UCase("ButtonRight") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ButtonRight + Case UCase("Cancel") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Cancel + Case UCase("Caption") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Caption + Case UCase("ClickCount") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ClickCount + Case UCase("ContextShortcut") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.ContextShortcut + Case UCase("ControlSource") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ControlSource + Case UCase("ControlTipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ControlTipText + Case UCase("ControlType") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ControlType + Case UCase("Count") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCOLLECTION,OBJOPTIONGROUP)) Then Goto Exit_Function + _getProperty = pvItem.Count + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.CurrentRecord + Case UCase("DataType") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.DataType + Case UCase("DbType") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.DbType + Case UCase("Default") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Default + Case UCase("DefaultValue") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function + _getProperty = pvItem.DefaultValue + Case UCase("Description") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.Description + Case UCase("EditMode") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.EditMode + Case UCase("Enabled") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Enabled + Case UCase("EOF") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.EOF + Case UCase("EventName") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.EventName + Case UCase("EventType") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.EventType + Case UCase("FieldSize") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.FieldSize + Case UCase("Filter") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function + _getProperty = pvItem.Filter + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.FilterOn + Case UCase("FocusChangeTemporary") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.FocusChangeTemporary + Case UCase("FontBold") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontBold + Case UCase("FontItalic") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontItalic + Case UCase("FontName") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontName + Case UCase("FontSize") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontSize + Case UCase("FontUnderline") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontUnderline + Case UCase("FontWeight") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.FontWeight + Case UCase("ForeColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ForeColor + Case UCase("Form") + If Not Utils._CheckArgument(pvItem, 1, CTLSUBFORM) Then Goto Exit_Function + _getProperty = pvItem.Form + Case UCase("Format") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Format + Case UCase("Height") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + _getProperty = pvItem.Height + Case UCase("Index") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Index + Case UCase("IsLoaded") + If Not Utils._CheckArgument(pvItem, 1, OBJFORM) Then Goto Exit_Function + _getProperty = pvItem.IsLoaded + Case UCase("ItemData") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.ItemData Else _getProperty = pvItem.ItemData(pvIndex) + Case UCase("KeyAlt") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyAlt + Case UCase("KeyChar") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyChar + Case UCase("KeyCode") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyCode + Case UCase("KeyCtrl") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyCtrl + Case UCase("KeyFunction") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyFunction + Case UCase("KeyShift") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.KeyShift + Case UCase("LinkChildFields") + If Not Utils._CheckArgument(pvItem, 1, OBJSUBFORM) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.LinkChildFields Else _getProperty = pvItem.LinkChildFields(pvIndex) + Case UCase("LinkMasterFields") + If Not Utils._CheckArgument(pvItem, 1, OBJSUBFORM) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.LinkMasterFields Else _getProperty = pvItem.LinkMasterFields(pvIndex) + Case UCase("ListCount") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ListCount + Case UCase("ListIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.ListIndex + Case UCase("Locked") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsNull(pvItem.Locked) Then Goto Trace_Error + _ge ExitProperty = pvItem.Locked + Case UCase("MultiSelect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.MultiSelect + Case UCase("Name") + If Not Utils._CheckArgument(pvItem, 1, _ + Array(OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJDIALOG, OBJTABLEDEF, OBJRECORDSET, OBJFIELD, OBJTEMPVAR, OBJCOMMANDBAR) _ + ) Then Goto Exit_Function + _getProperty = pvItem.Name + Case UCase("ObjectType") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJDATABASE, OBJCOLLECTION, OBJFORM, OBJDIALOG, OBJSUBFORM, OBJCONTROL _ + , OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY, OBJRECORDSET, OBJTABLEDEF, OBJFIELD, OBJTEMPVAR _ + , OBJCOMMANDBAR, OBJCOMMANDBARCONTROL) _ + ) Then Goto Exit_Function + _getProperty = pvItem.ObjectType + Case UCase("OnAction") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.OnAction + Case UCase("OpenArgs") + If Not Utils._CheckArgument(pvItem, 1, OBJFORM) Then Goto Exit_Function + _getProperty = pvItem.OpenArgs + Case UCase("OptionValue") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.OptionValue + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.OrderBy + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.OrderByOn + Case UCase("Page") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Page + Case UCase("Parent") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJSUBFORM, OBJCONTROL, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Parent + Case UCase("Recommendation") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.Recommendation + Case UCase("RecordCount") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + _getProperty = pvItem.RecordCount + Case UCase("Recordset") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.Recordset + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + _getProperty = pvItem.RecordSource + Case UCase("Required") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Required + Case UCase("RowChangeAction") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.RowChangeAction + Case UCase("RowSource") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.RowSource + Case UCase("RowSourceType") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.RowSourceType + Case UCase("Selected") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsMissing(pvIndex) Then _getProperty = pvItem.Selected Else _getProperty = pvItem.Selected(pvIndex) + Case UCase("Size") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.Size + Case UCase("Source") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.Source + Case UCase("SourceTable") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.SourceTable + Case UCase("SourceField") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.SourceField + Case UCase("SpecialEffect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.SpecialEffect + Case UCase("SubComponentName") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.SubComponentName + Case UCase("SubComponentType") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + _getProperty = pvItem.SubComponentType + Case UCase("SubType") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.SubType + Case UCase("TabIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TabIndex + Case UCase("TabStop") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TabStop + Case UCase("Tag") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Tag + Case UCase("Text") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.Text + Case UCase("TextAlign") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TextAlign + Case UCase("TooltipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TooltipText + Case UCase("TripleState") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + _getProperty = pvItem.TripleState + Case UCase("TypeName") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + _getProperty = pvItem.TypeName + Case UCase("Value") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function + _getProperty = pvItem.Value + Case UCase("Visible") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + _getProperty = pvItem.Visible + Case UCase("Width") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + _getProperty = pvItem.Width + Case UCase("XPos") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + If IsNull(pvItem.XPos) Then Goto Trace_Error + _getProperty = pvItem.XPos + Case UCase("YPos") + If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function + If IsNull(pvItem.YPos) Then Goto Trace_Error + _getProperty = pvItem.YPos + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _getProperty = Nothing + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _getProperty = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "_getProperty", Erl) + _getProperty = Nothing + GoTo Exit_Function +End Function ' _getProperty V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasProperty(ByVal psObject As String, ByVal pvPropertiesList() As Variant, Optional ByVal pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) +' Generic hasProperty function called from all class modules + +Dim sObject As String + sObject = Utils._PCase(psObject) + Utils._SetCalledSub(sObject & ".hasProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + + _hasProperty = False + If Not Utils._CheckArgument(pvProperty, 1, vbString) Then Goto Exit_Function + + _hasProperty = Utils._InList(pvProperty, pvPropertiesList(), False, True) + +Exit_Function: + Utils._ResetCalledSub(sObject & ".hasProperty") + Exit Function +End Function ' _hasProperty + +REM ------------------------------------------------------------------------------------------------------------------------ +Public Function _ParentObject(psShortcut As String) As Object +' Return parent object from shortcut as a string + +Dim sParent As String, vParent() As Variant, iBound As Integer + vParent = Split(psShortcut, "!") + iBound = UBound(vParent) - 1 + ReDim Preserve vParent(0 To iBound) ' Remove last element + sParent = Join(vParent, "!") + + 'Remove ".Form" if present +Const cstForm = ".FORM" + Set _ParentObject = Nothing + If Len(sParent) > Len(cstForm) Then + If UCase(Right(sParent, Len(cstForm))) = cstForm Then + Set _ParentObject = getValue(sParent) + Else + Set _ParentObject = getObject(sParent) + End If + End If + +End Function ' _ParentObject V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Properties(ByVal psObject As String _ + , ByRef pvParent As Object _ + , ByVal pvPropertiesList() As Variant _ + , ByVal Optional pvIndex As Variant _ + ) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise +' Generic function called from Properties methods stored in classes + +Dim vProperties As Variant, oCounter As Object, opProperty As Object +Dim iArgNr As Integer, iLen As Integer + + Utils._SetCalledSub(psObject & ".Properties") + + vProperties = Null + + If IsMissing(pvIndex) Then ' Call without index argument prepares a Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLPROPERTIES + Set oCounter._Parent = pvParent + oCounter._Count = UBound(pvPropertiesList) + 1 + Set vProperties = oCounter + Else + iLen = Len(psObject) + 1 + If Len(_A2B_.CalledSub) > iLen Then + If Left(_A2B_.CalledSub, iLen) = psObject & "." Then iArgNr = 1 Else iArgNr = 2 + End If + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + If pvIndex < LBound(pvPropertiesList) Or pvIndex > UBound(pvPropertiesList) Then + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Else + Set opProperty = New Property + Set opProperty._This = opProperty + opProperty._Name = pvPropertiesList(pvIndex) + opProperty._Value = Null + Set vProperties = opProperty + End If + End If + +Exit_Function: + Set _Properties = vProperties + Utils._ResetCalledSub(psObject & ".Properties") + Exit Function +End Function ' _Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _PropertiesList(pvObject As Variant) As Variant +' Return an array of strings containing the list of valid properties of pvObject + +Dim vProperties As Variant +Dim vPropertiesList As Variant, bPropertiesList() As Boolean, sPropertiesList() As String +Dim i As Integer, j As Integer, iCount As Integer + + Set vProperties = Nothing + Select Case pvObject._Type + Case OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJEVENT, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _ + , OBJDATABASE, OBJTABLEDEF, OBJQUERYDEF, OBJDIALOG, OBJFIELD, OBJRECORDSET, OBJTEMPVAR _ + , OBJCOMMANDBAR, OBJCOMMANDBARCONTROL + vPropertiesList = pvObject._PropertiesList() + Case Else + End Select + +Exit_Function: + Set _PropertiesList = vPropertiesList + Exit Function +End Function ' PropertiesList V0.9.0 + + \ No newline at end of file diff --git a/wizards/source/access2base/PropertiesSet.xba b/wizards/source/access2base/PropertiesSet.xba new file mode 100644 index 000000000..100806bea --- /dev/null +++ b/wizards/source/access2base/PropertiesSet.xba @@ -0,0 +1,577 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAbsolutePosition(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAbsolutePosition") + setAbsolutePosition = PropertiesSet._setProperty(pvObject, "AbsolutePosition", pvValue) +End Function ' setAbsolutePosition + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAllowAdditions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowAdditions") + setAllowAdditions = PropertiesSet._setProperty(pvObject, "AllowAdditions", pvValue) +End Function ' setAllowAdditions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAllowDeletions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowDeletions") + setAllowDeletions = PropertiesSet._setProperty(pvObject, "AllowDeletions", pvValue) +End Function ' setAllowDeletions + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setAllowEdits(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowEdits") + setAllowEdits = PropertiesSet._setProperty(pvObject, "AllowEdits", pvValue) +End Function ' setAllowEdits + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBackColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBackColor") + setBackColor = PropertiesSet._setProperty(pvObject, "BackColor", pvValue) +End Function ' setBackColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBookmark(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBookmark") + setBookmark = PropertiesSet._setProperty(pvObject, "Bookmark", pvValue) +End Function ' setBookmark + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBorderColor (Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderColor") + setBorderColor = PropertiesSet._setProperty(pvObject, "BorderColor", pvValue) +End Function ' setBorderColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setBorderStyle(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderStyle") + setBorderStyle = PropertiesSet._setProperty(pvObject, "BorderStyle", pvValue) +End Function ' setBorderStyle + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setCancel(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCancel") + setCancel = PropertiesSet._setProperty(pvObject, "Cancel", pvValue) +End Function ' setCancel + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setCaption(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCaption") + setCaption = PropertiesSet._setProperty(pvObject, "Caption", pvValue) +End Function ' setCaption + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setControlTipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setControlTipText") + setControlTipText = PropertiesSet._setProperty(pvObject, "ControlTipText", pvValue) +End Function ' setControlTipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setCurrentRecord(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCurrentRecord") + setCurrentRecord = PropertiesSet._setProperty(pvObject, "CurrentRecord", pvValue) +End Function ' setCurrentRecord + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDefault(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefault") + setDefault = PropertiesSet._setProperty(pvObject, "Default", pvValue) +End Function ' setDefault + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDefaultValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefaultValue") + setDefaultValue = PropertiesSet._setProperty(pvObject, "DefaultValue", pvValue) +End Function ' setDefaultValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDescription(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDescription") + setDescription = PropertiesSet._setProperty(pvObject, "Description", pvValue) +End Function ' setDescription + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setEnabled(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setEnabled") + setEnabled = PropertiesSet._setProperty(pvObject, "Enabled", pvValue) +End Function ' setEnabled + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFilter(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilter") + setFilter = PropertiesSet._setProperty(pvObject, "Filter", pvValue) +End Function ' setFilter + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFilterOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilterOn") + setFilterOn = PropertiesSet._setProperty(pvObject, "FilterOn", pvValue) +End Function ' setFilterOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontBold(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontBold") + setFontBold = PropertiesSet._setProperty(pvObject, "FontBold", pvValue) +End Function ' setFontBold + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontItalic(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontItalic") + setFontItalic = PropertiesSet._setProperty(pvObject, "FontItalic", pvValue) +End Function ' setFontItalic + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontName(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontName") + setFontName = PropertiesSet._setProperty(pvObject, "FontName", pvValue) +End Function ' setFontName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontSize(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontSize") + setFontSize = PropertiesSet._setProperty(pvObject, "FontSize", pvValue) +End Function ' setFontSize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontUnderline(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontUnderline") + setFontUnderline = PropertiesSet._setProperty(pvObject, "FontUnderline", pvValue) +End Function ' setFontUnderline + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setFontWeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontWeight") + setFontWeight = PropertiesSet._setProperty(pvObject, "FontWeight", pvValue) +End Function ' setFontWeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setForeColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setForeColor") + setForeColor = PropertiesSet._setProperty(pvObject, "ForeColor", pvValue) +End Function ' setForeColor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setHeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setHeight") + setHeight = PropertiesSet._setProperty(pvObject, "Height", pvValue) +End Function ' setHeight + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setListIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setListIndex") + setListIndex = PropertiesSet._setProperty(pvObject, "ListIndex", pvValue) +End Function ' setListIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setLocked(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setLocked") + setLocked = PropertiesSet._setProperty(pvObject, "Locked", pvValue) +End Function ' setLocked + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setMultiSelect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setMultiSelect") + setMultiSelect = PropertiesSet._setProperty(pvObject, "MultiSelect", pvValue) +End Function ' setMultiSelect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOnAction(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOnAction") + setOnAction = PropertiesSet._setProperty(pvObject, "OnAction", pvValue) +End Function ' setOnAction + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOptionValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOptionValue") + setOptionValue = PropertiesSet._setProperty(pvObject, "OptionValue", pvValue) +End Function ' setOptionValue + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOrderBy(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderBy") + setOrderBy = PropertiesSet._setProperty(pvObject, "OrderBy", pvValue) +End Function ' setOrderBy + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setOrderByOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderByOn") + setOrderByOn = PropertiesSet._setProperty(pvObject, "OrderByOn", pvValue) +End Function ' setOrderByOn + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setPage(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setPage") + setPage = PropertiesSet._setProperty(pvObject, "Page", pvValue) +End Function ' setPage V0.9.1 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(Optional pvItem As Variant, ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Variant +' Return True if property setting OK + Utils._SetCalledSub("setProperty") + If IsMissing(pvItem) Or IsMissing(psProperty) Or IsMissing(pvValue) Or IsEmpty(pvItem) Then Call _TraceArguments() + If IsMissing(pvIndex) Then + setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue) + Else + setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue, pvIndex) + End If + Utils._ResetCalledSub("setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRecordSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRecordSource") + setRecordSource = PropertiesSet._setProperty(pvObject, "RecordSource", pvValue) +End Function ' setRecordSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRequired(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRequired") + setRequired = PropertiesSet._setProperty(pvObject, "Required", pvValue) +End Function ' setRequired + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRowSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSource") + setRowSource = PropertiesSet._setProperty(pvObject, "RowSource", pvValue) +End Function ' setRowSource + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setRowSourceType(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSourceType") + setRowSourceType = PropertiesSet._setProperty(pvObject, "RowSourceType", pvValue) +End Function ' setRowSourceType + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelected(Optional pvObject As Variant, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Then Call _TraceArguments("setSelected") + If IsEmpty(pvObject) Then Call _TraceArguments("setSelected") + If IsMissing(pvIndex) Then + setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue) + Else + setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue, pvIndex) + End If +End Function ' setSelected + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelLength(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelLength") + setSelLength = PropertiesSet._setProperty(pvObject, "SelLength", pvValue) +End Function ' setSelLength + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelStart(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelStart") + setSelStart = PropertiesSet._setProperty(pvObject, "SelStart", pvValue) +End Function ' setSelStart + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelText") + setSelText = PropertiesSet._setProperty(pvObject, "SelText", pvValue) +End Function ' setSelText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSpecialEffect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSpecialEffect") + setSpecialEffect = PropertiesSet._setProperty(pvObject, "SpecialEffect", pvValue) +End Function ' setSpecialEffect + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTabIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabIndex") + setTabIndex = PropertiesSet._setProperty(pvObject, "TabIndex", pvValue) +End Function ' setTabIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTabStop(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabStop") + setTabStop = PropertiesSet._setProperty(pvObject, "TabStop", pvValue) +End Function ' setTabStop + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTag(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTag") + setTag = PropertiesSet._setProperty(pvObject, "Tag", pvValue) +End Function ' setTag + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTextAlign(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTextAlign") + setTextAlign = PropertiesSet._setProperty(pvObject, "TextAlign", pvValue) +End Function ' setTextAlign + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTooltipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTooltipText") + setTooltipText = PropertiesSet._setProperty(pvObject, "TooltipText", pvValue) +End Function ' setTooltipText + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setTripleState(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTripleState") + setTripleState = PropertiesSet._setProperty(pvObject, "TripleState", pvValue) +End Function ' setTripleState + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setVisible(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms and controls + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setVisible") + setVisible = PropertiesSet._setProperty(pvObject, "Visible", pvValue) +End Function ' setVisible + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setWidth(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean +' Only for open forms + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setWidth") + setWidth = PropertiesSet._setProperty(pvObject, "Width", pvValue) +End Function ' setWidth + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private Function _CheckProperty(pvObject As Object, ByVal psProperty As String) As Boolean +' Return False if psProperty not within the PropertyValues set of pvItem + +Dim i As Integer, oPropertyValues As Variant, oProperty As Variant + oPropertyValues = pvObject.PropertyValues + + For i = LBound(oPropertyValues) To UBound(oPropertyValues) + oProperty = oPropertyValues(i) + If UCase(oProperty.Name) = UCase(psProperty) Then + _CheckProperty = True + Exit Function + End If + Next i + + _CheckProperty = False + Exit Function + +End Function ' CheckProperty V0.7.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _setProperty(pvItem As Variant, ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + +'pvItem must be an object and have the requested property + If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function +'Check Index argument + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 4, Utils._AddNumeric()) Then Goto Exit_Function + End If +'Execute +Dim iArgNr As Integer, lFormat As Long +Dim i As Integer, iCount As Integer, iSelectedItems() As Integer, bListboxBound As Boolean +Dim odbDatabase As Object, vNames As Variant, bFound As Boolean, sName As String, oModel As Object +Dim ocButton As Variant, iRadioIndex As Integer + _setProperty = True + If _A2B_.CalledSub = "setProperty" Then iArgNr = 3 Else iArgNr = 2 + If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error_Control + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function + pvItem.AbsolutePosition = pvValue + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.AllowAdditions = pvValue + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.AllowDeletions = pvValue + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.AllowEdits = pvValue + Case UCase("BackColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.BackColor = pvValue + Case UCase("Bookmark") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function + pvItem.Bookmark = pvValue + Case UCase("BorderColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.BorderColor = pvValue + Case UCase("BorderStyle") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.BorderColor = pvValue + Case UCase("Cancel") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Cancel = pvValue + Case UCase("Caption") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function + pvItem.Caption = pvValue + Case UCase("ControlTipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.ControlTipText = pvValue + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.CurrentRecord = pvValue + Case UCase("Default") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Default = pvValue + Case UCase("DefaultValue") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function + pvItem.DefaultValue = pvValue + Case UCase("Description") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function + pvItem.DefaultValue = pvValue + Case UCase("Enabled") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Enabled = pvValue + Case UCase("Filter") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function + pvItem.Filter = pvValue + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.FilterOn = pvValue + Case UCase("FontBold") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontBold = pvValue + Case UCase("FontItalic") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontItalic = pvValue + Case UCase("FontName") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontName = pvValue + Case UCase("FontSize") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontSize = pvValue + Case UCase("FontUnderline") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontUnderline = pvValue + Case UCase("FontWeight") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.FontWeight = pvValue + Case UCase("ForeColor") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.ForeColor = pvValue + Case UCase("Height") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + pvItem.Height = pvValue + Case UCase("ListIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.ListIndex = pvValue + Case UCase("Locked") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Locked = pvValue + Case UCase("MultiSelect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.MultiSelect = pvValue + Case UCase("OnAction") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + pvItem.OnAction = pvValue + Case UCase("OptionValue") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.OptionValue = pvValue + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.OrderBy = pvValue + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.OrderByOn = pvValue + Case UCase("Page") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function + pvItem.Page = pvValue + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function + pvItem.RecordSource = pvValue + Case UCase("Required") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Required = pvValue + Case UCase("RowSource") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.RowSource = pvValue + Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.RowSourceType = pvValue + Case UCase("Selected") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If IsMissing(pvIndex) Then pvItem.Selected = pvValue Else pvItem.SelectedI(pvValue, pvIndex) + Case UCase("SelLength") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelLength = pvValue + Case UCase("SelStart") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelStart = pvValue + Case UCase("SelText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelText = pvValue + Case UCase("SpecialEffect") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SpecialEffect = pvValue + Case UCase("TabIndex") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TabIndex = pvValue + Case UCase("TabStop") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TabStop = pvValue + Case UCase("Tag") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.Tag = pvValue + Case UCase("TextAlign") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TextAlign = pvValue + Case UCase("TooltipText") + If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function + pvItem.TooltipText = pvValue + Case UCase("TripleState") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.TripleState = pvValue + Case UCase("Value") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function + pvItem.Value = pvValue + Case UCase("Visible") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function + pvItem.Visible = pvValue + Case UCase("Width") + If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function + pvItem.Width = pvValue + Case Else + Goto Trace_Error_Control + End Select + +Exit_Function: + Utils._ResetCalledSub("set" & psProperty) + Exit Function +Trace_Error_Form: + TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, 1, pvItem._Name) + _setProperty = False + Goto Exit_Function +Trace_Error_Control: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _setProperty = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _setProperty = False + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _setProperty = Nothing + Goto Exit_Function +Trace_Error_Array: + TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr) + _setProperty = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "_setProperty", Erl) + GoTo Exit_Function +End Function ' _setProperty V0.9.1 + + \ No newline at end of file diff --git a/wizards/source/access2base/Property.xba b/wizards/source/access2base/Property.xba new file mode 100644 index 000000000..8b881c284 --- /dev/null +++ b/wizards/source/access2base/Property.xba @@ -0,0 +1,152 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be PROPERTY +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Value As Variant +Private _ParentDatabase As Object + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJPROPERTY + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _Value = Null +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Property.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Property.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Name", "ObjectType", "Value") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("Property.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + _PropertyGet = _Value + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("Property.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "Property._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + + \ No newline at end of file diff --git a/wizards/source/access2base/Python.xba b/wizards/source/access2base/Python.xba new file mode 100644 index 000000000..94a442159 --- /dev/null +++ b/wizards/source/access2base/Python.xba @@ -0,0 +1,613 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub DebugPrint(ParamArray pvArgs() As Variant) + +'Print arguments unconditionally in console +'Arguments are separated by a TAB (simulated by spaces) +'Some pvArgs might be missing: a TAB is still generated + +Dim vVarTypes() As Variant, i As Integer +Const cstTab = 5 + On Local Error Goto Exit_Sub ' Never interrupt processing + Utils._SetCalledSub("DebugPrint") + vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, vbArray + vbByte)) + + If UBound(pvArgs) >= 0 Then + For i = 0 To UBound(pvArgs) + If Not Utils._CheckArgument(pvArgs(i), i + 1, vVarTypes(), , False) Then pvArgs(i) = "[TYPE?]" + Next i + End If + +Dim sOutput As String, sArg As String + sOutput = "" + For i = 0 To UBound(pvArgs) + sArg = Replace(Utils._CStr(pvArgs(i), _A2B_.DebugPrintShort), "\;", ";") + ' Add argument to output + If i = 0 Then + sOutput = sArg + Else + sOutput = sOutput & Space(cstTab - (Len(sOutput) Mod cstTab)) & sArg + End If + Next i + + TraceLog(TRACEANY, sOutput, False) + +Exit_Sub: + Utils._ResetCalledSub("DebugPrint") + Exit Sub +End Sub ' DebugPrint V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PYTHON WRAPPERS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PythonEventsWrapper(Optional poEvent As Variant) As Variant +' Python wrapper when Application.Events() method is invoked +' The ParamArray mechanism empties UNO objects when they are member of the arguments list +' As a workaround, the Application.Events function is executed directly + + If _ErrorHandler() Then On Local Error GoTo Exit_Function ' Do never interrupt + PythonEventsWrapper = Null + +Dim vReturn As Variant, vArray As Variant +Const cstObject = 1 + + vReturn = Application.Events(poEvent) + vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type) + + PythonEventsWrapper = vArray + +Exit_Function: + Exit Function +End Function ' PythonEventsWrapper V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PythonWrapper(ByVal pvCallType As Variant _ + , ByVal pvObject As Variant _ + , ByVal pvScript As Variant _ + , ParamArray pvArgs() As Variant _ + ) As Variant +' Called from Python to apply +' - on object with entry pvObject in PythonCache +' Conventionally: -1 = Application +' -2 = DoCmd +' - a script pvScript which type is described by pvCallType +' - with arguments pvArgs(0)... (max. 8 for object methods) +' The value returned by the method/property is encapsulated in an array +' [0] => 0 = scalar or array returned by the method +' => 1 = basic object returned by the method +' => 2 = a null value +' [1] => the object reference or the returned value (complemented with arguments passed by reference, if any) or Null +' [2] => the object type or Null +' [3] => the object name, if any +' or, when pvCallType == vbUNO, as the UNO object returned by the property + +Dim vReturn As Variant, vArray As Variant +Dim vObject As Variant, sScript As String, sModule As String +Dim i As Integer, iNbArgs As Integer, vArg As Variant, vArgs() As Variant + +Const cstApplication = -1, cstDoCmd = -2 +Const cstScalar = 0, cstObject = 1, cstNull = 2, cstUNO = 3 + +'Conventional special values +Const cstNoArgs = "+++NOARGS+++", cstSymEmpty = "+++EMPTY+++", cstSymNull = "+++NULL+++", cstSymMissing = "+++MISSING+++" + +'https://support.office.com/en-us/article/CallByName-fonction-49ce9475-c315-4f13-8d35-e98cfe98729a +'Determines the pvCallType +Const vbGet = 2, vbLet = 4, vbMethod = 1, vbSet = 8, vbUNO = 16 + + If _ErrorHandler() Then On Local Error GoTo Error_Function + PythonWrapper = Null + + 'Reinterpret arguments one by one into vArgs, examine iso-dates and conventional NoArgs/Empty/Null values + iNbArgs = -1 + vArgs = Array() + If UBound(pvArgs) >= 0 Then + For i = 0 To UBound(pvArgs) + vArg = pvArgs(i) + If i = 0 And VarType(vArg) = vbString Then + If vArg = cstNoArgs Then Exit For + End If + If VarType(vArg) = vbString Then + If vArg = cstSymEmpty Then + vArg = Empty + ElseIf vArg = cstSymNull Then + vArg = Null + ElseIf vArg = cstSymMissing Then + Exit For ' Next arguments must be missing also + Else + vArg = _CDate(vArg) + End If + End If + iNbArgs = iNbArgs + 1 + ReDim Preserve vArgs(iNbArgs) + vArgs(iNbArgs) = vArg + Next i + End If + + 'Check pvObject + Select Case pvObject ' Always numeric + Case cstApplication + sModule = "Application" + Select Case pvScript + Case "AllDialogs" : If iNbArgs < 0 Then vReturn = Application.AllDialogs() Else vReturn = Application.AllDialogs(vArgs(0)) + Case "AllForms" : If iNbArgs < 0 Then vReturn = Application.AllForms() Else vReturn = Application.AllForms(vArgs(0)) + Case "AllModules" : If iNbArgs < 0 Then vReturn = Application.AllModules() Else vReturn = Application.AllModules(vArgs(0)) + Case "CloseConnection" + vReturn = Application.CloseConnection() + Case "CommandBars" : If iNbArgs < 0 Then vReturn = Application.CommandBars() Else vReturn = Application.CommandBars(vArgs(0)) + Case "CurrentDb" : vReturn = Application.CurrentDb() + Case "CurrentUser" : vReturn = Application.CurrentUser() + Case "DAvg" : vReturn = Application.DAvg(vArgs(0), vArgs(1), vArgs(2)) + Case "DCount" : vReturn = Application.DCount(vArgs(0), vArgs(1), vArgs(2)) + Case "DLookup" : vReturn = Application.DLookup(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "DMax" : vReturn = Application.DMax(vArgs(0), vArgs(1), vArgs(2)) + Case "DMin" : vReturn = Application.DMin(vArgs(0), vArgs(1), vArgs(2)) + Case "DStDev" : vReturn = Application.DStDev(vArgs(0), vArgs(1), vArgs(2)) + Case "DStDevP" : vReturn = Application.DStDevP(vArgs(0), vArgs(1), vArgs(2)) + Case "DSum" : vReturn = Application.DSum(vArgs(0), vArgs(1), vArgs(2)) + Case "DVar" : vReturn = Application.DVar(vArgs(0), vArgs(1), vArgs(2)) + Case "DVarP" : vReturn = Application.DVarP(vArgs(0), vArgs(1), vArgs(2)) + Case "Forms" : If iNbArgs < 0 Then vReturn = Application.Forms() Else vReturn = Application.Forms(vArgs(0)) + Case "getObject" : vReturn = Application.getObject(vArgs(0)) + Case "getValue" : vReturn = Application.getValue(vArgs(0)) + Case "HtmlEncode" : vReturn = Application.HtmlEncode(vArgs(0), vArgs(1)) + Case "OpenDatabase" : vReturn = Application.OpenDatabase(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "ProductCode" : vReturn = Application.ProductCode() + Case "setValue" : vReturn = Application.setValue(vArgs(0), vArgs(1)) + Case "SysCmd" : vReturn = Application.SysCmd(vArgs(0), vArgs(1), vARgs(2)) + Case "TempVars" : If iNbArgs < 0 Then vReturn = Application.TempVars() Else vReturn = Application.TempVars(vArgs(0)) + Case "Version" : vReturn = Application.Version() + Case Else + GoTo Error_Proc + End Select + Case cstDoCmd + sModule = "DoCmd" + Select Case pvScript + Case "ApplyFilter" : vReturn = DoCmd.ApplyFilter(vArgs(0), vArgs(1), vArgs(2)) + Case "Close" : vReturn = DoCmd.mClose(vArgs(0), vArgs(1), vArgs(2)) + Case "CopyObject" : vReturn = DoCmd.CopyObject(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "FindNext" : vReturn = DoCmd.FindNext() + Case "FindRecord" : vReturn = DoCmd.FindRecord(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case "GetHiddenAttribute" + vReturn = DoCmd.GetHiddenAttribute(vArgs(0), vArgs(1)) + Case "GoToControl" : vReturn = DoCmd.GoToControl(vArgs(0)) + Case "GoToRecord" : vReturn = DoCmd.GoToRecord(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "Maximize" : vReturn = DoCmd.Maximize() + Case "Minimize" : vReturn = DoCmd.Minimize() + Case "MoveSize" : vReturn = DoCmd.MoveSize(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "OpenForm" : vReturn = DoCmd.OpenForm(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case "OpenQuery" : vReturn = DoCmd.OpenQuery(vArgs(0), vArgs(1), vArgs(2)) + Case "OpenReport" : vReturn = DoCmd.OpenReport(vArgs(0), vArgs(1)) + Case "OpenSQL" : vReturn = DoCmd.OpenSQL(vArgs(0), vArgs(1)) + Case "OpenTable" : vReturn = DoCmd.OpenTable(vArgs(0), vArgs(1), vArgs(2)) + Case "OutputTo" : vReturn = DoCmd.OutputTo(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7)) + Case "Quit" : _A2B_.CalledSub = "Quit" : GoTo Error_Action + Case "RunApp" : vReturn = DoCmd.RunApp(vArgs(0)) + Case "RunCommand" : vReturn = DoCmd.RunCommand(vArgs(0)) + Case "RunSQL" : vReturn = DoCmd.RunSQL(vArgs(0), vArgs(1)) + Case "SelectObject" : vReturn = DoCmd.SelectObject(vArgs(0), vArgs(1), vArgs(2)) + Case "SendObject" : vReturn = DoCmd.SendObject(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7), vArgs(8), vArgs(9)) + Case "SetHiddenAttribute" + vReturn = DoCmd.SetHiddenAttribute(vArgs(0), vArgs(1), vArgs(2)) + Case "SetOrderBy" : vReturn = DoCmd.SetOrderBy(vArgs(0), vArgs(1)) + Case "ShowAllRecords" + vReturn = DoCmd.ShowAllRecords() + Case Else + GoTo Error_Proc + End Select + Case Else + ' Locate targeted object + If pvObject > UBound(_A2B_.PythonCache) Or pvObject < 0 Then GoTo Error_Object + Set vObject = _A2B_.PythonCache(pvObject) + If IsNull(vObject) Then + If pvScript = "Dispose" Then GoTo Exit_Function Else GoTo Error_Object + End If + ' Preprocessing + sScript = pvScript + sModule = vObject._Type + Select Case sScript + Case "Add" + If vObject._Type = "COLLECTION" And vObject._CollType = COLLTABLEDEFS Then vArgs = Array(_A2B_.PythonCache(vArgs(0))) + Case "Close" + sSCript = "mClose" + Case "Type" + sScript = "pType" + Case Else + End Select + ' Execute method + Select Case UBound(vArgs) ' Dirty but ... CallByName does not support an array of arguments or return values + Case -1 + If pvCallType = vbUNO Then + With vObject + Select Case sScript ' List all properties that should be called directly (UNO) + Case "BoundField" : vReturn = .BoundField + Case "Column" : vReturn = .Column + Case "Connection" : vReturn = .Connection + case "ContainerWindow" : vReturn = .ContainerWindow + Case "ControlModel" : vReturn = .ControlModel + Case "ControlView" : vReturn = .ControlView + Case "DatabaseForm" : vReturn = .DatabaseForm + Case "Document" : vReturn = .Document + Case "FormsCollection" : vReturn = .FormsCollection + Case "LabelControl" : vReturn = .LabelControl + Case "MetaData" : vReturn = .MetaData + Case "ParentComponent" : vReturn = .ParentComponent + Case "Query" : vReturn = .Query + Case "RowSet" : vReturn = .RowSet + Case "Table" : vReturn = .Table + Case "UnoDialog" : vReturn = .UnoDialog + Case Else + End Select + End With + ElseIf sScript = "ItemData" Then ' List all properties that should be called directly (arrays not supported by CallByName) + vReturn = vObject.ItemData + ElseIf sScript = "LinkChildFields" Then + vReturn = vObject.LinkChildFields + ElseIf sScript = "LinkMasterFields" Then + vReturn = vObject.LinkMasterFields + ElseIf sScript = "OpenArgs" Then + vReturn = vObject.OpenArgs + ElseIf sScript = "Selected" Then + vReturn = vObject.Selected + ElseIf sScript = "Value" Then + vReturn = vObject.Value + Else + vReturn = CallByName(vObject, sScript, pvCallType) + End If + Case 0 + Select Case sScript + Case "AppendChunk" ' Arg is a vector, not supported by CallByName + vReturn = vObject.GetChunk(vArgs(0), vArgs(1)) + Case "GetRows" ' Returns an array, not supported by CallByName + vReturn = vObject.GetRows(vArgs(0), True) ' Force iso dates + Case Else + vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0)) + End Select + Case 1 + Select Case sScript + Case "GetChunk" ' Returns a vector, not supported by CallByName + vReturn = vObject.GetChunk(vArgs(0), vArgs(1)) + Case Else + vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1)) + End Select + Case 2 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2)) + Case 3 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case 4 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + Case 5 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5)) + Case 6 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case 7 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7)) + End Select + ' Postprocessing + Select Case pvScript + Case "Close", "Dispose", "Terminate" + Set _A2B_.PythonCache(pvObject) = Nothing + Case "Move", "MoveFirst", "MoveLast", "MoveNext", "MovePrevious" ' Pass the new BOF, EOF values (binary format) + If vObject._Type = "RECORDSET" Then + vReturn = (Iif(vObject.BOF, 1, 0) * 2 + Iif(vObject.EOF, 1, 0)) * Iif(vReturn, 1, -1) + End If + Case "Find" ' Store in array the arguments passed by reference + If vObject._Type = "MODULE" And vReturn = True Then + vReturn = Array(vReturn, vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + End If + Case "ProcOfLine" ' Store in array the arguments passed by reference + vReturn = Array(vReturn, vArgs(1)) + Case Else + End Select + End Select + + ' Structure the returned array + If pvCallType = vbUNO Then + vArray = vReturn + Else + If IsNull(vReturn) Then + vArray = Array(cstNull, Null, Null) + ElseIf IsObject(vReturn) Then + Select Case vReturn._Type + Case "COLLECTION", "COMMANDBARCONTROL", "EVENT" + vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type) + Case Else + vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type, vReturn.Name) + End Select + Else + If VarType(vReturn) = vbDate Then + vArray = Array(cstScalar, _CStr(vReturn), Null) + ElseIf VarType(vReturn) = vbBigint Then ' Could happen for big integer database fields + vArray = Array(cstScalar, CLng(vReturn), Null) + Else + vArray = Array(cstScalar, vReturn, Null) + End If + End If + End If + + PythonWrapper = vArray + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "PythonWrapper", Erl) + GoTo Exit_Function +Error_Object: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, "Python Wrapper (" & pvScript & ")", 0, , Array(_GetLabel("OBJECT"), "#" & pvObject)) + GoTo Exit_Function +Error_Action: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) + GoTo Exit_Function +Error_Proc: + TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, "Python Wrapper", 0, , Array(pvScript, sModule)) + GoTo Exit_Function +End Function ' PythonWrapper V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PYTHON HELPER FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyConvertFromUrl(ByVal pvFile As Variant) As String +' Convenient function to have common conversions of filenames from/to url notations both in Python and Basic + + On Local Error GoTo Exit_Function + PyConvertFromUrl = "" + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + + PyConvertFromUrl = ConvertFromUrl(pvFile) + +Exit_Function: + Exit Function +End Function ' PyConvertFromUrl V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyConvertToUrl(ByVal pvFile As Variant) As String +' Convenient function to have common conversions of filenames from/to url notations both in Python and Basic + + On Local Error GoTo Exit_Function + PyConvertToUrl = "" + If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function + + PyConvertToUrl = ConvertToUrl(pvFile) + +Exit_Function: + Exit Function +End Function ' PyConvertToUrl V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyCreateUnoService(ByVal pvService As Variant) As Variant +' Convenient function to create a UNO service in Python + + On Local Error GoTo Exit_Function + Set PyCreateUnoService = Nothing + If Not Utils._CheckArgument(pvService, 1, vbString) Then Goto Exit_Function + + Set PyCreateUnoService = CreateUnoService(pvService) + +Exit_Function: + Exit Function +End Function ' PyCreateUnoService V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDateAdd(ByVal pvAdd As Variant _ + , ByVal pvCount As Variant _ + , ByVal pvDate As Variant _ + ) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate As Variant, vNewDate As Variant + On Local Error GoTo Exit_Function + PyDateAdd = Null + + If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvCount, 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate, 3, vbString) Then Goto Exit_Function + + vDate = _CDate(pvDate) + vNewDate = DateAdd(pvAdd, pvCount, vDate) + If VarType(vNewDate) = vbDate Then PyDateAdd = _CStr(vNewDate) Else PyDateAdd = vNewDate + +Exit_Function: + Exit Function +End Function ' PyDateAdd V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDateDiff(ByVal pvAdd As Variant _ + , ByVal pvDate1 As Variant _ + , ByVal pvDate2 As Variant _ + , ByVal pvWeekStart As Variant _ + , ByVal pvYearStart As Variant _ + ) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate1 As Variant, vDate2 As Variant + On Local Error GoTo Exit_Function + PyDateDiff = Null + + If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate1, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate2, 3, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 4, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 5, Utils._AddNumeric()) Then Goto Exit_Function + + vDate1 = _CDate(pvDate1) + vDate2 = _CDate(pvDate2) + PyDateDiff = DateDiff(pvAdd, vDate1, vDate2, pvWeekStart, pvYearStart) + +Exit_Function: + Exit Function +End Function ' PyDateDiff V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDatePart(ByVal pvAdd As Variant _ + , ByVal pvDate As Variant _ + , ByVal pvWeekStart As Variant _ + , ByVal pvYearStart As Variant _ + ) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate As Variant + On Local Error GoTo Exit_Function + PyDatePart = Null + + If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvDate, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 3, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvWeekStart, 4, Utils._AddNumeric()) Then Goto Exit_Function + + vDate = _CDate(pvDate) + PyDatePart = DatePart(pvAdd, vDate, pvWeekStart, pvYearStart) + +Exit_Function: + Exit Function +End Function ' PyDatePart V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyDateValue(ByVal pvDate As Variant) As Variant +' Convenient shortcut to useful and easy-to-use Basic date functions + +Dim vDate As Variant + On Local Error GoTo Exit_Function + PyDateValue = Null + If Not Utils._CheckArgument(pvDate, 1, vbString) Then Goto Exit_Function + + vDate = DateValue(pvDate) + If VarType(vDate) = vbDate Then PyDateValue = _CStr(vDate) Else PyDateValue = vDate + +Exit_Function: + Exit Function +End Function ' PyDateValue V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyFormat(ByVal pvValue As Variant, pvFormat As Variant) As String +' Convenient function to format numbers or dates + + On Local Error GoTo Exit_Function + PyFormat = "" + If Not Utils._CheckArgument(pvValue, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + pvValue = _CDate(pvValue) + If IsEmpty(pvFormat) Then + PyFormat = Str(pvValue) + Else + If Not Utils._CheckArgument(pvFormat, 2, vbString) Then Goto Exit_Function + PyFormat = Format(pvValue, pvFormat) + End If + +Exit_Function: + Exit Function +End Function ' PyFormat V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyGetGUIType() As Variant + + PyGetGUIType = GetGUIType() + +End Function ' PyGetGUIType V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyGetSystemTicks() As Variant + + PyGetSystemTicks = GetSystemTicks() + +End Function ' PyGetSystemTicks V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyGlobalScope(ByVal pvLib As Variant) As Variant + + Select Case pvLib + Case "Basic" + PyGlobalScope = GlobalScope.BasicLibraries() + Case "Dialog" + PyGlobalScope = GlobalScope.DialogLibraries() + Case Else + End Select + +End Function ' PyGlobalScope V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyInputBox(ByVal pvText As Variant _ + , ByVal pvTitle As Variant _ + , ByVal pvDefault As Variant _ + , ByVal pvXPos As Variant _ + , ByVal pvYPos As Variant _ + ) As Variant +' Convenient function to open input box from Python + + On Local Error GoTo Exit_Function + PyInputBox = Null + + If Not Utils._CheckArgument(pvText, 1, vbString) Then Goto Exit_Function + If IsEmpty(pvTitle) Then pvTitle = "" + If Not Utils._CheckArgument(pvTitle, 2, vbString) Then Goto Exit_Function + If IsEmpty(pvDefault) Then pvDefault = "" + If Not Utils._CheckArgument(pvDefault, 3, vbString) Then Goto Exit_Function + + If IsEmpty(pvXPos) Or IsEmpty(pvYPos) Then + PyInputBox = InputBox(pvText, pvTitle, pvDefault) + Else + If Not Utils._CheckArgument(pvXPos, 4, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvYPos, 5, Utils._AddNumeric()) Then Goto Exit_Function + PyInputBox = InputBox(pvText, pvTitle, pvDefault, pvXPos, pvYPos) + End If + +Exit_Function: + Exit Function +End Function ' PyInputBox V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyMsgBox(ByVal pvText As Variant _ + , ByVal pvType As Variant _ + , ByVal pvDialogTitle As Variant _ + ) As Variant +' Convenient function to open message box from Python + + On Local Error GoTo Exit_Function + PyMsgBox = Null + + If Not Utils._CheckArgument(pvText, 1, vbString) Then Goto Exit_Function + If IsEmpty(pvType) Then pvType = 0 + If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric()) Then Goto Exit_Function + If IsEmpty(pvDialogTitle) Then + PyMsgBox = MsgBox(pvText, pvType) + Else + If Not Utils._CheckArgument(pvDialogTitle, 3, vbString) Then Goto Exit_Function + PyMsgBox = MsgBox(pvText, pvType, pvDialogTitle) + End If + +Exit_Function: + Exit Function +End Function ' PyMsgBox V6.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function PyTimer() As Long +' Convenient function to call Timer from Python + + PyTimer = Timer + +End Function ' PyTimer V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _CDate(ByVal pvValue As Variant) As Variant +' Return a Date type if iso date, otherwise return input + +Dim vValue As Variant + vValue = pvValue + If VarType(pvValue) = vbString Then + If pvValue <> "" And IsDate(pvValue) Then vValue = CDate(pvValue) ' IsDate("") gives True !? + End If + _CDate = vValue + +End Function + + \ No newline at end of file diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba new file mode 100644 index 000000000..eaa186fa6 --- /dev/null +++ b/wizards/source/access2base/Recordset.xba @@ -0,0 +1,1274 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be RECORDSET +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String ' Unique, generated +Private _Fields() As Variant +Private _ParentName As String +Private _ParentType As String +Private _ParentDatabase As Object +Private _ForwardOnly As Boolean +Private _PassThrough As Boolean +Private _ReadOnly As Boolean +Private _CommandType As Long +Private _Command As String +Private _DataSet As Boolean ' True if execute() successful +Private _BOF As Boolean +Private _EOF As Boolean +Private _Filter As String +Private _EditMode As Integer ' dbEditxxx constants +Private _BookmarkBeforeNew As Variant +Private _BookmarkLastModified As Variant +Private _IsClone As Boolean +Private _ManageChunks As Variant ' Array of ChunkDescriptors +Private RowSet As Object ' com.sun.star.comp.dba.ORowSet + +Type ChunkDescriptor + ChunksRequested As Boolean + FieldName As String + ChunkType As Integer ' vbString or vbByte + FileName As String + FileHandler As Object +End Type + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJRECORDSET + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _Fields = Array() + _ParentName = "" + Set _ParentDatabase = Nothing + _ParentType = "" + _ForwardOnly = False + _PassThrough = False + _ReadOnly = False + _CommandType = 0 + _Command = "" + _DataSet = False + _BOF = True + _EOF = True + _Filter = "" + _EditMode = dbEditNone + _BookmarkBeforeNew = Null + _BookmarkLastModified = Null + _IsClone = False + Set _ManageChunks = Array() + Set RowSet = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + mClose() +End Sub + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AbsolutePosition() As Variant + AbsolutePosition = _PropertyGet("AbsolutePosition") +End Property ' AbsolutePosition (get) + +Property Let AbsolutePosition(ByVal pvValue As Variant) + Call _PropertySet("AbsolutePosition", pvValue) +End Property ' AbsolutePosition (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get BOF() As Boolean + BOF = _PropertyGet("BOF") +End Property ' BOF (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Bookmark() As Variant + Bookmark = _PropertyGet("Bookmark") +End Property ' Bookmark (get) + +Property Let Bookmark(ByVal pvValue As Variant) + Call _PropertySet("Bookmark", pvValue) +End Property ' Bookmark (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Bookmarkable() As Boolean + Bookmarkable = _PropertyGet("Bookmarkable") +End Property ' Bookmarkable (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EOF() As Boolean + EOF = _PropertyGet("EOF") +End Property ' EOF (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get EditMode() As Integer + EditMode = _PropertyGet("EditMode") +End Property ' EditMode (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Filter() As Variant + Filter = _PropertyGet("Filter") +End Property ' Filter (get) + +Property Let Filter(ByVal pvValue As Variant) + Call _PropertySet("Filter", pvValue) +End Property ' Filter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get LastModified() As Variant +' DO NOT PUBLISH + LastModified = _PropertyGet("LastModified") +End Property ' LastModified (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RecordCount() As Long + RecordCount = _PropertyGet("RecordCount") +End Property ' RecordCount (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AddNew() As Boolean +' Initiates the creation of a new record + +Const cstThisSub = "Recordset.AddNew" +Dim i As Integer, iFieldsCount As Integer, oField As Object +Dim sDefault As String, oColumn As Object +Dim iValue As Integer, lValue As Long, sgValue As Single, dbValue As Double, dValue As Date +Dim vTemp As Variant + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + AddNew = False + + With RowSet + 'Is inserting a new row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + If Not .CanUpdateInsertedRows Then Goto Error_NoUpdate + If Not .IsBookmarkable Then Goto Error_NoUpdate + If _EditMode <> dbEditNone Then CancelUpdate() + If _BOF And _EOF Then ' Records before first or after last do not have a bookmark + _BookmarkBeforeNew = "_BOF_" + ElseIf .isBeforeFirst() Then + _BookmarkBeforeNew = "_BOF_" + ElseIf .isAfterLast() Then + _BookmarkBeforeNew = "_EOF_" + Else + _BookmarkBeforeNew = .getBookmark() + End If + + .moveToInsertRow() + + 'Set all fields to their default value + iFieldsCount = Fields().Count + On Local Error Resume Next ' Do not stop if default setting fails + For i = 0 To iFieldsCount - 1 + Set oField = Fields(i) + Set oColumn = oField.Column + sDefault = oField.DefaultValue + If sDefault = "" Then ' No default value + If oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then oColumn.updateNull() + Else + With com.sun.star.sdbc.DataType + Select Case oColumn.Type + Case .BIT, .BOOLEAN + If sDefault = "1" Then oColumn.updateBoolean(True) Else oColumn.updateBoolean(False) + Case .TINYINT + iValue = CInt(sDefault) + If iValue >= -128 And iValue <= +127 Then oColumn.updateShort(iValue) + Case .SMALLINT + lValue = CLng(sDefault) + If lValue >= -32768 And lValue <= 32767 Then oColumn.updateInt(lValue) + Case .INTEGER + lValue = CLng(sDefault) + If lValue >= -2147483648 And lValue <= 2147483647 Then oColumn.updateInt(lValue) + Case .BIGINT + lValue = CLng(sDefault) + Column.updateLong(lValue) ' No proper type conversion for HYPER data type + Case .FLOAT + sgValue = CSng(sDefault) + If Abs(sgValue) < 3.402823E38 And Abs(sgValue) > 1.401298E-45 Then oColumn.updateFloat(sgValue) + Case .REAL, .DOUBLE + dbValue = CDbl(sDefault) + 'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue) + oColumn.updateDouble(dbValue) + Case .NUMERIC, .DECIMAL + dbValue = CDbl(sDefault) + If Utils._hasUNOProperty(Column, "Scale") Then + If Column.Scale > 0 Then + 'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue) + oColumn.updateDouble(dbValue) + Else + oColumn.updateString(sDefault) + End If + Else + oColumn.updateString(sDefault) + End If + Case .CHAR, .VARCHAR, .LONGVARCHAR + oColumn.updateString(sDefault) ' vbString + Case .DATE + dValue = DateValue(sDefault) + vTemp = New com.sun.star.util.Date + With vTemp + .Day = Day(dValue) + .Month = Month(dValue) + .Year = Year(dValue) + End With + oColumn.updateDate(vTemp) + Case .TIME + dValue = TimeValue(sDefault) + vTemp = New com.sun.star.util.Time + With vTemp + .Hours = Hour(dValue) + .Minutes = Minute(dValue) + .Seconds = Second(dValue) + '.HundredthSeconds = 0 + End With + oColumn.updateTime(vTemp) + Case .TIMESTAMP + dValue = DateValue(sDefault) + vTemp = New com.sun.star.util.DateTime + With vTemp + .Day = Day(dValue) + .Month = Month(dValue) + .Year = Year(dValue) + .Hours = Hour(dValue) + .Minutes = Minute(dValue) + .Seconds = Second(dValue) + '.HundredthSeconds = 0 + End With + oColumn.updateTimestamp(vTemp) +' Case .BINARY, .VARBINARY, .LONGVARBINARY + ' Case .BLOB +' Case .CLOB + Case Else + End Select + End With + End If + Next i + End With + If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0 + + _EditMode = dbEditAdd + AddNew = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' AddNew + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CancelUpdate() As Boolean +' Cancel any edit action + +Const cstThisSub = "Recordset.CancelUpdate" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + CancelUpdate = False + + With RowSet + Select Case _EditMode + Case dbEditNone + Case dbEditAdd + _AppendChunkClose(True) + If Not IsNull(_BookmarkBeforeNew) Then + Select Case _BookmarkBeforeNew + Case "_BOF_" : .beforeFirst() + Case "_EOF_" : .afterLast() + Case Else : .moveToBookmark(_BookmarkBeforeNew) + End Select + End If + Case dbEditInProgress + .cancelRowUpdates() + _AppendChunkClose(True) + End Select + End With + + _EditMode = dbEditNone + _BookmarkBeforeNew = Null + _BookmarkLastModified = Null + CancelUpdate = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CancelUpdate + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Clone() As Object +' Duplicate an existing recordset + +Const cstThisSub = "Recordset.Clone" + +Const cstNull = -1 +Dim iType As Integer, iOptions As Integer, iLockEdit As Integer + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Set Clone = Nothing + + If _IsClone Then Goto Error_Clone + If _ForwardOnly Then iType = dbOpenForwardOnly Else iType = cstNull + If _PassThrough Then iOptions = dbSQLPassThrough Else iOptions = cstNull + iLockEdit = dbReadOnly ' Always read-only + + Set Clone = OpenRecordset(iType, iOptions, iLockEdit, True) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_Clone: + TraceError(TRACEFATAL, ERRRECORDSETCLONE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Clone + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose(ByVal Optional pbRemove As Boolean) As Variant +' Dispose UNO objects +' If pbRemove = True, remove recordset from Recordsets collection + +Const cstThisSub = "Recordset.Close" +Dim i As Integer + + If _ErrorHandler() Then On Local Error Goto Exit_Function ' Do not stop execution + Utils._SetCalledSub(cstThisSub) + If Not IsNull(RowSet) Then + RowSet.close() + RowSet.dispose() + End If + _ForwardOnly = False + _PassThrough = False + _ReadOnly = False + _CommandType = 0 + _Command = "" + _ParentName = "" + _ParentType = "" + _DataSet = False + _BOF = True + _EOF = True + _Filter = "" + _EditMode = dbEditNone + _BookmarkBeforeNew = Null + _BookmarkLastModified = Null + _IsClone = False + For i = 0 To UBound(_Fields) + If Not IsNull(_Fields(i)) Then + _Fields(i).Dispose() + Set _Fields(i) = Nothing + End If + Next i + _Fields = Array() + Set RowSet = Nothing + If IsMissing(pbRemove) Then pbRemove = True + If pbRemove Then _ParentDatabase.RecordsetsColl.Remove(_Name) + Set _ParentDatabase = Nothing + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Close + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Delete() As Boolean +' Deletes the current record + +Const cstThisSub = "Recordset.Delete" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Delete = False + + 'Is deleting a row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + If _EditMode <> dbEditNone Then + CancelUpdate() + Goto Error_Sequence + End If + If RowSet.rowDeleted() Then Goto Error_RowDeleted + + RowSet.deleteRow() + Delete = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + Goto Exit_Function +End Function ' Delete + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Edit() As Boolean +' Updates the current record + +Const cstThisSub = "Recordset.Edit" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Edit = False + + 'Is updating a row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + If _EditMode <> dbEditNone Then CancelUpdate() + If RowSet.rowDeleted() Then Goto Error_RowDeleted + + _EditMode = dbEditInProgress + Edit = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Edit + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Fields(ByVal Optional pvIndex As Variant) As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Recordset.Fields" + Utils._SetCalledSub(cstThisSub) + + Set Fields = Nothing + If Not IsMissing(pvIndex) Then + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + End If + +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, oFields As Object, iIndex As Integer + + ' No argument, return a collection + If IsMissing(pvIndex) Then + Set oObject = New Collect + Set oObject._This = oObject + oObject._CollType = COLLFIELDS + Set oObject._Parent = _This + oObject._Count = RowSet.getColumns().Count + Goto Exit_Function + End If + + Set oFields = RowSet.getColumns() + sObjects = oFields.ElementNames() + + ' Argument is the field name + If VarType(pvIndex) = vbString Then + iIndex = -1 + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sObjects) + If UCase(pvIndex) = UCase(sObjects(i)) Then + sObjectName = sObjects(i) + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then Goto Trace_NotFound + ' Argument is numeric + Else + If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError + sObjectName = sObjects(pvIndex) + iIndex = pvIndex + End If + + ' Check if field object already buffered in _Fields() array + If UBound(_Fields) < 0 Then ' Initialize _Fields + ReDim _Fields(0 To UBound(sObjects)) + For i = 0 To UBound(sObjects) + Set _Fields(i) = Nothing + Next i + End If + If Not IsNull(_Fields(iIndex)) Then + Set oObject = _Fields(iIndex) + ' Otherwise create new field object + Else + Set oObject = New Field + Set oObject._This = oObject + oObject._Name = sObjectName + Set oObject.Column = oFields.getByName(sObjectName) + If Utils._hasUNOProperty(oObject.Column, "Precision") Then oObject._Precision = oObject.Column.Precision + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oObject._ParentDatabase = _ParentDatabase + Set oObject._ParentRecordset = _This + Set _Fields(iIndex) = oObject + End If + +Exit_Function: + Set Fields = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) + Goto Exit_Function +Trace_IndexError: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Fields + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + +Const cstThisSub = "Recordset.getProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub(cstThisSub) + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetRows(ByVal Optional pvNumRows As variant, ByVal Optional pbStrDate As Boolean) As Variant +' UNPUBLISHED - pbStrDate = True forces all dates to be converted into strings + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Recordset.GetRows" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pbStrDate) Then pbStrDate = False + +Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer + vMatrix() = Array() + If IsMissing(pvNumRows) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvNumRows, 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvNumRows < 1 Then Goto Trace_Error + If IsNull(RowSet) Then Goto Trace_Closed + If Not _DataSet Then Goto Exit_Function + + If _EditMode <> dbEditNone Then CancelUpdate() + + If _EOF Then Goto Exit_Function + + lSize = -1 + iNumFields = RowSet.getColumns().Count - 1 + If iNumFields < 0 Then Goto Exit_Function + + ReDim vMatrix(0 To iNumFields, 0 To pvNumRows - 1) + + Do While Not _EOF And lSize < pvNumRows - 1 + lSize = lSize + 1 + For i = 0 To iNumFields + vMatrix(i, lSize) = Utils._getResultSetColumnValue(RowSet, i + 1) + If pbStrDate And IsDate(vMatrix(i, lSize)) Then vMatrix(i, lSize) = _CStr(vMatrix(i, lSize)) + Next i + _Move("NEXT") + Loop + If lSize < pvNumRows - 1 Then ' Resize to number of fetched records + ReDim Preserve vMatrix(0 To iNumFields, 0 To lSize) + End If + +Exit_Function: + GetRows() = vMatrix() + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvNumRows)) + Set Controls = Nothing + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' GetRows V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + +Const cstThisSub = "Recordset.hasProperty" + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Utils._ResetCalledSub(cstThisSub) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Move(ByVal Optional pvRelative As Variant, ByVal Optional pvBookmark As variant) As Boolean +' Move record pointer Relative rows vs. bookmark or current record + + If IsMissing(pvRelative) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvRelative, 1, Utils._AddNumeric()) Then Goto Exit_Function + + If IsMissing(pvBookmark) Then Move = _Move(pvRelative) Else Move = _Move(pvRelative, pvBookmark) + +Exit_Function: + Exit Function +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveFirst() As Boolean + MoveFirst = _Move("First") +End Function ' MoveFirst + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveLast() As Boolean + MoveLast = _Move("Last") +End Function ' MoveLast + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MoveNext() As Boolean + MoveNext = _Move("Next") +End Function ' MoveNext + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function MovePrevious() As Boolean + MovePrevious = _Move("Previous") +End Function ' MovePrevious + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenRecordset(ByVal Optional pvType As Variant _ + , ByVal Optional pvOptions As Variant _ + , ByVal Optional pvLockEdit As Variant _ + , ByVal Optional pbClone As Boolean) As Object +'Return a Recordset object based on current recordset object with filter addition + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" + Utils._SetCalledSub(cstThisSub) + Set OpenRecordset = Nothing +Const cstNull = -1 + +Dim oObject As Object + Set oObject = Nothing + If IsMissing(pvType) Then + pvType = cstNull + Else + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function + End If + If IsMissing(pvOptions) Then + pvOptions = cstNull + Else + If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + If IsMissing(pvLockEdit) Then + pvLockEdit = cstNull + Else + If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function + End If + If IsMissing(pbClone) Then pbClone = False ' pbClone is a not published argument + + Set oObject = New Recordset + With oObject + ._CommandType = _CommandType + ._Command = _Command + ._ParentName = _Name + ._ParentType = _Type + Set ._ParentDatabase = _ParentDatabase + Set ._This = oObject + ._ForwardOnly = ( pvType = dbOpenForwardOnly ) + ._PassThrough = ( pvOptions = dbSQLPassThrough ) + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) + Select Case True + Case pbClone : Call ._Initialize(, RowSet) + Case _Filter <> "" : Call ._Initialize(_Filter) + Case Else : Call ._Initialize() + End Select + End With + With _ParentDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty + +Exit_Function: + Set OpenRecordset = oObject + Set oObject = Nothing + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' OpenRecordset + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Const cstThisSub = "Recordset.Properties" + Utils._SetCalledSub(cstThisSub) +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + Set vProperty._ParentDatabase = _ParentDatabase + +Exit_Function: + Set Properties = vProperty + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Const cstThisSub = "Recordset.setProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Update() As Boolean +' Finalize the updates of the current record + +Const cstThisSub = "Recordset.Update" + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub(cstThisSub) + Update = False + + 'Is updating a row allowed ? + If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate + With RowSet + If .rowDeleted() Then Goto Error_RowDeleted + Select Case _EditMode + Case dbEditNone + Goto Trace_Error_Update + Case dbEditAdd + _AppendChunkClose(False) + If .IsNew And .IsModified Then .insertRow() + _BookmarkLastModified = .getBookmark() + If Not IsNull(_BookmarkBeforeNew) Then + Select Case _BookmarkBeforeNew + Case "_BOF_" : .beforeFirst() + Case "_EOF_" : .afterLast() + Case Else : .moveToBookmark(_BookmarkBeforeNew) + End Select + End If + Case dbEditInProgress + _AppendChunkClose(False) + If .IsModified Then + .updateRow() + _BookmarkLastModified = .getBookmark() + End If + End Select + End With + _EditMode = dbEditNone + Update = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_Error_Update: + TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) + Goto Exit_Function +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' Update + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AppendChunk(ByVal psFieldName As String, ByRef pvChunk As Variant, piChunkType) As Boolean +' Write chunk at the end of the file dedicated to the given field + + If _ErrorHandler() Then On Local Error GoTo Error_Function +Dim oFileAccess As Object +Dim i As Integer, oChunk As Object, iChunk As Integer + + ' Do nothing if chunk meaningless + _AppendChunk = False + If IsNull(pvChunk) Then GoTo Exit_Function + If IsArray(pvChunk) Then + If UBound(pvChunk) < LBound(pvChunk) Then GoTo Exit_Function ' Empty array + End If + + ' Find or create relevant chunk entry + iChunk = -1 + For i = 0 To UBound(_ManageChunks) + Set oChunk = _ManageChunks(i) + If oChunk.FieldName = psFieldName Then + iChunk = i + Exit For + End If + Next i + If iChunk = -1 Then + _AppendChunkInit(psFieldName) + iChunk = UBound(_ManageChunks) + End If + + Set oChunk = _ManageChunks(iChunk) + With oChunk + If Not .ChunksRequested Then ' First chunk + .ChunksRequested = True + .ChunkType = piChunkType + .FileName = Utils._GetRandomFileName(_Name) + Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + .FileHandler = oFileAccess.openFileWrite(.FileName) + End If + .FileHandler.writeBytes(pvChunk) + End With + _AppendChunk = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Recordset._AppendChunk", Erl) + GoTo Exit_Function +End Function ' AppendChunk V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AppendChunkClose(ByVal pbCancel As Boolean) As Boolean +' Stores file content to database field(s) +' Called from Update() [pbCancel = False] or CancelUpdate() [pbCancel = True] + + If _ErrorHandler() Then On Local Error GoTo Error_Function +Dim oFileAccess As Object, oStream As Object, lFileLength As Long, oField As Object +Dim i As Integer, oChunk As Object + + _AppendChunkClose = False + For i = 0 To UBound(_ManageChunks) + Set oChunk = _ManageChunks(i) + With oChunk + If Not .ChunksRequested Then GoTo Exit_Function + If IsNull(.FileHandler) Then GoTo Exit_Function + .Filehandler.closeOutput + Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + ' Copy file to field + If Not pbCancel Then + Set oStream = oFileAccess.openFileRead(.FileName) + lFileLength = oStream.getLength() + If lFileLength > 0 Then + Set oField = RowSet.getColumns.getByName(.FieldName) + Select Case .ChunkType + Case vbByte + oField.updateBinaryStream(oStream, lFileLength) +' Case vbString ' DOES NOT WORK FOR CHARACTER TYPES +' oField.updateCharacterStream(oStream, lFileLength) + End Select + End If + oStream.closeInput() + End If + If oFileAccess.exists(.FileName) Then oFileAccess.kill(.FileName) + End With + Next i + Set _ManageChunks = Array() + _AppendChunkClose = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "Recordset._AppendChunkClose", Erl) + GoTo Exit_Function +End Function ' AppendChunkClose V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AppendChunkInit(psFieldName As String) As Boolean +' Initialize chunks manager + +Dim iSize As Integer + iSize = UBound(_ManageChunks) + 1 + ReDim Preserve _ManageChunks(0 To iSize) + Set _ManageChunks(iSize) = New ChunkDescriptor + With _ManageChunks(iSize) + .ChunksRequested = False + .FieldName = psFieldName + .FileName = "" + Set .FileHandler = Nothing + End With + +End Function ' AppendChunkInit V1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _Initialize(ByVal Optional pvFilter As Variant, Optional poRowSet As Object) +' Initialize new recordset + +Dim sFilter As String + + If _Command = "" Then Exit Sub + + If _ErrorHandler() Then On Local Error Goto Error_Sub + If VarType(pvFilter) = vbError Then + sFilter = "" + ElseIf IsMissing(pvFilter) Then + sFilter = "" + Else + sFilter = pvFilter + End If + If Not IsMissing(poRowSet) Then ' Clone + Set RowSet = poRowSet.createResultSet() + _IsClone = True + RowSet.last() ' Solves bookmark desynchro when parent bookmark is used ?!? + Else + Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet") + _IsClone = False + With RowSet + If IsNull(.ActiveConnection) Then Set .ActiveConnection = _ParentDatabase.Connection + .CommandType = _CommandType + .Command = _Command + If _ForwardOnly Then .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY _ + Else .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_SENSITIVE + If _PassThrough Then .EscapeProcessing = False _ + Else .EscapeProcessing = True + If _ReadOnly Then + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_UNCOMMITTED ' Dirty read + Else + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.UPDATABLE + .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_COMMITTED + End If + End With + + If sFilter <> "" Then ' Filter must be set before execute() + RowSet.Filter = sFilter + RowSet.ApplyFilter = True + End If + On Local Error Goto SQL_Error + RowSet.execute() + On Local Error Goto Error_Sub + End If + _DataSet = True +'If the Recordset contains no records, the BOF and EOF properties are True, and there is no current record. + _BOF = ( RowSet.IsRowCountFinal And RowSet.RowCount = 0 ) + _EOF = _BOF + +Exit_Sub: + Exit Sub +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , _Command) + Goto Exit_Sub +Error_Sub: + TraceError(TRACEABORT, Err, "Recordset._Initialize", Erl) + GoTo Exit_Sub +End Sub ' _Initialize + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Move(pvTarget As Variant, ByVal Optional pvBookmark As Variant, ByVal Optional pbAbsolute As Boolean) As Boolean +'Move to the first, last, next, or previous record in a specified Recordset object and make that record the current record. + +Dim cstThisSub As String + cstThisSub = "Recordset.Move" & Iif(VarType(pvTarget) = vbString, pvTarget, "") + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + + If IsNull(RowSet) Then Goto Trace_Closed + If Not _DataSet Then Goto Trace_NoData + If _BOF And _EOF Then Goto Trace_NoData + _Move = False + CancelUpdate() ' Any Move cancels all updates, even Move(0) ! + +Dim l As Long, lRow As Long + With RowSet + Select Case VarType(pvTarget) + Case vbString + Select Case UCase(pvTarget) + Case "FIRST" + If _ForwardOnly Then + If Not ( .isBeforeFirst() Or .isFirst() ) Then + Goto Trace_Forward + Else + .next() + End If + Else + .first() + End If + Case "LAST" + If _ForwardOnly Then + If .isAfterLast() Then Goto Trace_Forward + Do While Not ( .isRowCountFinal And .Row = .RowCount ) ' isLast() = True after reading of first records chunk + .next() + Loop + Else + .last() + End If + Case "NEXT" + If _EOF Then Goto Trace_OutOfRange + .next() + Case "PREVIOUS" + If _ForwardOnly Then Goto Trace_Forward + If _BOF Then Goto Trace_OutOfRange + .previous() + End Select + Case Else ' Relative or absolute move + If IsMissing(pbAbsolute) Then pbAbsolute = False ' Relative move is default + If _ForwardOnly And pvTarget < 0 then Goto Trace_Forward + If IsMissing(pvBookmark) Then + If pvTarget = 0 Then Goto Exit_Function ' Do nothing + If _ForwardOnly Then + If pbAbsolute Then lRow = .getRow() Else lRow = 0 + For l = 1 To pvTarget - lRow + If .isAfterLast() Then Exit For + .next() + Next l + Else + If pbAbsolute Then .absolute(pvTarget) Else .relative(pvTarget) + End If + Else ' Move is always relative when bookmark argument present + If _ForwardOnly Then Goto Trace_Forward + If pvTarget = 0 Then + .moveToBookmark(pvBookmark) + Else + .moveRelativeToBookmark(pvBookmark, pvTarget) + End If + End If + End Select + + _BOF = .isBeforeFirst() ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=76640 + _EOF = .isAfterlast() + If _BOF Or _EOF Then + _Move = False + Else + If .rowDeleted() Then Goto Error_RowDeleted + If .rowUpdated() Then .refreshRow() + _Move = True + End If + End With + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Exit_Close: ' Force close of recordset when error raised + mClose() + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Close +Trace_Forward: + TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0) + Goto Exit_Close +Trace_NoData: + TraceError(TRACEFATAL, ERRRECORDSETNODATA, Utils._CalledSub(), 0) + Goto Exit_Close +Trace_OutOfRange: + TraceError(TRACEFATAL, ERRRECORDSETRANGE, Utils._CalledSub(), 0) + Goto Exit_Close +Error_RowDeleted: + TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Close +End Function ' Move + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("AbsolutePosition", "BOF", "Bookmarkable", "Bookmark", "EditMode" _ + , "EOF", "Filter", "LastModified", "Name", "ObjectType" , "RecordCount" _ + ) + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "Recordset.get" + Utils._SetCalledSub(cstThisSub & psProperty) + + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If IsNull(RowSet) Then Goto Trace_Closed + With RowSet + Select Case True + Case _BOF And _EOF : _PropertyGet = -1 + Case .isBeforeFirst() Or .isAfterLast() : _PropertyGet = -1 + Case Else : _PropertyGet = .getRow() ' Not getRow() - 1 as MSAccess requires + End Select + End With + Case UCase("BOF") + If IsNull(RowSet) Then Goto Trace_Closed + Select Case True + Case _BOF And _EOF : _PropertyGet = True + Case RowSet.isBeforeFirst() : _PropertyGet = True + Case Else : _PropertyGet = False + End Select + Case UCase("Bookmarkable") + If IsNull(RowSet) Then Goto Trace_Closed + If _ForwardOnly Then _PropertyGet = False Else _PropertyGet = RowSet.IsBookmarkable + Case UCase("Bookmark") + If IsNull(RowSet) Then Goto Trace_Closed + If RowSet.IsBookmarkable And Not _ForwardOnly Then + If _BOF Or _EOF Then _PropertyGet = Null Else _PropertyGet = RowSet.getBookmark() + Else + _PropertyGet = Null + If _ForwardOnly Then Goto Trace_Forward + End If + Case UCase("EditMode") + If IsNull(RowSet) Then Goto Trace_Closed + _PropertyGet = _EditMode + Case UCase("EOF") + If IsNull(RowSet) Then Goto Trace_Closed + Select Case True + Case _BOF And _EOF : _PropertyGet = True + Case RowSet.isAfterLast() : _PropertyGet = True + Case Else : _PropertyGet = False + End Select + Case UCase("Filter") + If IsNull(RowSet) Then Goto Trace_Closed + _PropertyGet = RowSet.Filter + Case UCase("LastModified") + If IsNull(RowSet) Then Goto Trace_Closed + If RowSet.IsBookmarkable And Not _ForwardOnly Then + _PropertyGet = _BookmarkLastModified + Else + _PropertyGet = Null + If _ForwardOnly Then Goto Trace_Forward + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("RecordCount") + If IsNull(RowSet) Then Goto Trace_Closed + _PropertyGet = RowSet.RowCount + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Forward: + TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0) + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + +Dim cstThisSub As String + cstThisSub = "Recordset.set" + Utils._SetCalledSub(cstThisSub & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer +Dim oObject As Object + + If _IsLeft(_A2B_.CalledSub, "Recordset.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("AbsolutePosition") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Then Goto Trace_Error_Value + _Move(pvValue, , True) + Case UCase("Bookmark") + If IsNull(RowSet) Then Goto Trace_Closed + _Move(0, pvValue) + Case UCase("Filter") + If IsNull(RowSet) Then Goto Trace_Closed + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + _Filter = _ParentDatabase._ReplaceSquareBrackets(pvValue) + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + diff --git a/wizards/source/access2base/Root_.xba b/wizards/source/access2base/Root_.xba new file mode 100644 index 000000000..73f743278 --- /dev/null +++ b/wizards/source/access2base/Root_.xba @@ -0,0 +1,311 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- FOR INTERNAL USE ONLY --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private ErrorHandler As Boolean +Private MinimalTraceLevel As Integer +Private TraceLogs() As Variant +Private TraceLogCount As Integer +Private TraceLogLast As Integer +Private TraceLogMaxEntries As Integer +Private LastErrorCode As Integer +Private LastErrorLevel As String +Private ErrorText As String +Private ErrorLongText As String +Private CalledSub As String +Private DebugPrintShort As Boolean +Private Introspection As Object ' com.sun.star.beans.Introspection +Private VersionNumber As String ' Actual Access2Base version number +Private Locale As String +Private ExcludeA2B As Boolean +Private TextSearch As Object +Private SearchOptions As Variant +Private FindRecord As Object +Private StatusBar As Object +Private Dialogs As Object ' Collection +Private TempVars As Object ' Collection +Private CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents +Private PythonCache() As Variant ' Array of objects created in Python scripts + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + VersionNumber = Access2Base_Version + ErrorHandler = True + MinimalTraceLevel = 0 + TraceLogs() = Array() + TraceLogCount = 0 + TraceLogLast = 0 + TraceLogMaxEntries = 0 + LastErrorCode = 0 + LastErrorLevel = "" + ErrorText = "" + ErrorLongText = "" + CalledSub = "" + DebugPrintShort = True + Locale = L10N._GetLocale() + ExcludeA2B = True + Set Introspection = CreateUnoService("com.sun.star.beans.Introspection") + Set TextSearch = CreateUnoService("com.sun.star.util.TextSearch") + SearchOptions = New com.sun.star.util.SearchOptions + With SearchOptions + .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP + .searchFlag = 0 + .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE + End With + Set FindRecord = Nothing + Set StatusBar = Nothing + Set Dialogs = New Collection + Set TempVars = New Collection + CurrentDoc = Array() + ReDim CurrentDoc(0 To 0) + Set CurrentDoc(0) = Nothing + PythonCache = Array() +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function AddPython(ByRef pvObject As Variant) As Long +' Store the object as a new entry in PythonCache and return its entry number + +Dim lVars As Long, vObject As Variant + + lVars = UBound(PythonCache) + 1 + ReDim Preserve PythonCache(0 To lVars) + PythonCache(lVars) = pvObject + + AddPython = lVars + +End Function ' AddPython V6.4 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub CloseConnection() +' Close all connections established by current document to free memory. +' - if Base document => close the one concerned database connection +' - if non-Base documents => close the connections of each individual standalone form + +Dim i As Integer, iCurrentDoc As Integer +Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant + + If ErrorHandler Then On Local Error Goto Error_Sub + + If Not IsArray(CurrentDoc) Then Goto Exit_Sub + If UBound(CurrentDoc) < 0 Then Goto Exit_Sub + iCurrentDoc = CurrentDocIndex( , False) ' False prevents error raising if not found + If iCurrentDoc < 0 Then GoTo Exit_Sub ' If not found ignore + + vDocContainer = CurrentDocument(iCurrentDoc) + With vDocContainer + If Not .Active Then GoTo Exit_Sub ' e.g. if multiple calls to CloseConnection() + For i = 0 To UBound(.DbContainers) + If Not IsNull(.DbContainers(i).Database) Then + .DbContainers(i).Database.Dispose() + Set .DbContainers(i).Database = Nothing + End If + TraceLog(TRACEANY, UCase(CalledSub) & " " & .URL & Iif(i = 0, "", " Form=" & .DbContainers(i).FormName), False) + Set .DbContainers(i) = Nothing + Next i + .DbContainers = Array() + .URL = "" + .DbConnect = 0 + .Active = False + Set .Document = Nothing + End With + CurrentDoc(iCurrentDoc) = vDocContainer + +Exit_Sub: + Exit Sub +Error_Sub: + TraceError(TRACEABORT, Err, CalledSub, Erl, False) ' No error message addressed to the user, only stored in console + GoTo Exit_Sub +End Sub ' CloseConnection + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties + +Dim iCurrentDoc As Integer + + Set CurrentDb = Nothing + + If Not IsArray(CurrentDoc) Then Goto Exit_Function + If UBound(CurrentDoc) < 0 Then Goto Exit_Function + iCurrentDoc = CurrentDocIndex(, False) ' False = no abort + If iCurrentDoc >= 0 Then + If UBound(CurrentDoc(iCurrentDoc).DbContainers) >= 0 Then Set CurrentDb = CurrentDoc(iCurrentDoc).DbContainers(0).Database + End If + +Exit_Function: + Exit Function +End Function ' CurrentDb + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDocIndex(Optional pvURL As Variant, Optional pbAbort As Variant) As Integer +' Returns the entry in CurrentDoc(...) referring to the current document + +Dim i As Integer, bFound As Boolean, sURL As String +Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument" + + bFound = False + CurrentDocIndex = -1 + + If Not IsArray(CurrentDoc) Then Goto Trace_Error + If UBound(CurrentDoc) < 0 Then Goto Trace_Error + For i = 1 To UBound(CurrentDoc) ' [0] reserved to database .odb document + If IsMissing(pvURL) Then ' Not on 1 single line ?!? + If Utils._hasUNOProperty(ThisComponent, "URL") Then + sURL = ThisComponent.URL + Else + Exit For ' f.i. ThisComponent = Basic IDE ... + End If + Else + sURL = pvURL ' To support the SelectObject action + End If + If CurrentDoc(i).Active And CurrentDoc(i).URL = sURL Then + CurrentDocIndex = i + bFound = True + Exit For + End If + Next i + + If Not bFound Then + If IsNull(CurrentDoc(0)) Then GoTo Trace_Error + With CurrentDoc(0) + If Not .Active Then GoTo Trace_Error + If IsNull(.Document) Then GoTo Trace_Error + End With + CurrentDocIndex = 0 + End If + +Exit_Function: + Exit Function +Trace_Error: + If IsMissing(pbAbort) Then pbAbort = True + If pbAbort Then TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Else CurrentDocIndex = -1 + Goto Exit_Function +End Function ' CurrentDocIndex + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDocument(ByVal Optional piDocIndex As Integer) As Variant +' Returns the CurrentDoc(...) referring to the current document or to the argument + +Dim iDocIndex As Integer + If IsMissing(piDocIndex) Then iDocIndex = CurrentDocIndex(, False) Else iDocIndex = piDocIndex + If iDocIndex >= 0 And iDocIndex <= UBound(CurrentDoc) Then Set CurrentDocument = CurrentDoc(iDocIndex) Else Set CurrentDocument = Nothing + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dump() +' For debugging purposes +Dim i As Integer, j As Integer, vCurrentDoc As Variant + On Local Error Resume Next + + DebugPrint "Version", VersionNumber + DebugPrint "TraceLevel", MinimalTraceLevel + DebugPrint "TraceCount", TraceLogCount + DebugPrint "CalledSub", CalledSub + If IsArray(CurrentDoc) Then + For i = 0 To UBound(CurrentDoc) + vCurrentDoc = CurrentDoc(i) + If Not IsNull(vCurrentDoc) Then + DebugPrint i, "URL", vCurrentDoc.URL + For j = 0 To UBound(vCurrentDoc.DbContainers) + DebugPrint i, j, "Form", vCurrentDoc.DbContainers(j).FormName + DebugPrint i, j, "Database", vCurrentDoc.DbContainers(j).Database.Title + Next j + End If + Next i + End If + +End Sub + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasItem(psCollType As String, ByVal psName As String) As Boolean +' Return True if psName if in the collection + +Dim oItem As Object + On Local Error Goto Error_Function ' Whatever ErrorHandler ! + + hasItem = True + Select Case psCollType + Case COLLALLDIALOGS + Set oItem = Dialogs.Item(UCase(psName)) + Case COLLTEMPVARS + Set oItem = TempVars.Item(UCase(psName)) + Case Else + hasItem = False + End Select + +Exit_Function: + Exit Function +Error_Function: ' Item by key aborted + hasItem = False + GoTo Exit_Function +End Function ' hasItem + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant +REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use) +REM With 2 arguments return the corresponding entry in Root + +Dim odbDatabase As Variant + If IsMissing(piDocEntry) Then + Set odbDatabase = CurrentDb() + Else + If Not IsArray(CurrentDoc) Then Goto Trace_Error + If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error + If piDocEntry > UBound(CurrentDoc) Then Goto Trace_Error + If piDbEntry > UBound(CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error + Set odbDatabase = CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database + End If + If IsNull(odbDatabase) Then GoTo Trace_Error + +Exit_Function: + Set _CurrentDb = odbDatabase + Exit Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) + Goto Exit_Function +End Function ' _CurrentDb + + \ No newline at end of file diff --git a/wizards/source/access2base/SubForm.xba b/wizards/source/access2base/SubForm.xba new file mode 100644 index 000000000..d905a9836 --- /dev/null +++ b/wizards/source/access2base/SubForm.xba @@ -0,0 +1,757 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be SUBFORM +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Shortcut As String +Private _Name As String +Private _MainForm As String +Private _DocEntry As Integer +Private _DbEntry As Integer +Private _OrderBy As String +Public ParentComponent As Object ' com.sun.star.text.TextDocument +Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJSUBFORM + Set _This = Nothing + Set _Parent = Nothing + _Shortcut = "" + _Name = "" + _MainForm = "" + _DocEntry = -1 + _DbEntry = -1 + _OrderBy = "" + Set ParentComponent = Nothing + Set DatabaseForm = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowAdditions() As Variant + AllowAdditions = _PropertyGet("AllowAdditions") +End Property ' AllowAdditions (get) + +Property Let AllowAdditions(ByVal pvValue As Variant) + Call _PropertySet("AllowAdditions", pvValue) +End Property ' AllowAdditions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowDeletions() As Variant + AllowDeletions = _PropertyGet("AllowDeletions") +End Property ' AllowDeletions (get) + +Property Let AllowDeletions(ByVal pvValue As Variant) + Call _PropertySet("AllowDeletions", pvValue) +End Property ' AllowDeletions (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get AllowEdits() As Variant + AllowEdits = _PropertyGet("AllowEdits") +End Property ' AllowEdits (get) + +Property Let AllowEdits(ByVal pvValue As Variant) + Call _PropertySet("AllowEdits", pvValue) +End Property ' AllowEdits (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get CurrentRecord() As Variant + CurrentRecord = _PropertyGet("CurrentRecord") +End Property ' CurrentRecord (get) + +Property Let CurrentRecord(ByVal pvValue As Variant) + Call _PropertySet("CurrentRecord", pvValue) +End Property ' CurrentRecord (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Filter() As Variant + Filter = _PropertyGet("Filter") +End Property ' Filter (get) + +Property Let Filter(ByVal pvValue As Variant) + Call _PropertySet("Filter", pvValue) +End Property ' Filter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get FilterOn() As Variant + FilterOn = _PropertyGet("FilterOn") +End Property ' FilterOn (get) + +Property Let FilterOn(ByVal pvValue As Variant) + Call _PropertySet("FilterOn", pvValue) +End Property ' FilterOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get LinkChildFields(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then LinkChildFields = _PropertyGet("LinkChildFields") Else LinkChildFields = _PropertyGet("LinkChildFields", pvIndex) +End Property ' LinkChildFields (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get LinkMasterFields(ByVal Optional pvIndex As Variant) As Variant + If IsMissing(pvIndex) Then LinkMasterFields = _PropertyGet("LinkMasterFields") Else LinkMasterFields = _PropertyGet("LinkMasterFields", pvIndex) +End Property ' LinkMasterFields (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +Public Function pName() As String ' For compatibility with < V0.9.0 + pName = _PropertyGet("Name") +End Function ' pName (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveCursorMove() As Variant + OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") +End Property ' OnApproveCursorMove (get) + +Property Let OnApproveCursorMove(ByVal pvValue As Variant) + Call _PropertySet("OnApproveCursorMove", pvValue) +End Property ' OnApproveCursorMove (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveParameter() As Variant + OnApproveParameter = _PropertyGet("OnApproveParameter") +End Property ' OnApproveParameter (get) + +Property Let OnApproveParameter(ByVal pvValue As Variant) + Call _PropertySet("OnApproveParameter", pvValue) +End Property ' OnApproveParameter (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' OnApproveReset (get) + +Property Let OnApproveReset(ByVal pvValue As Variant) + Call _PropertySet("OnApproveReset", pvValue) +End Property ' OnApproveReset (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveRowChange() As Variant + OnApproveRowChange = _PropertyGet("OnApproveRowChange") +End Property ' OnApproveRowChange (get) + +Property Let OnApproveRowChange(ByVal pvValue As Variant) + Call _PropertySet("OnApproveRowChange", pvValue) +End Property ' OnApproveRowChange (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnApproveSubmit() As Variant + OnApproveSubmit = _PropertyGet("OnApproveSubmit") +End Property ' OnApproveSubmit (get) + +Property Let OnApproveSubmit(ByVal pvValue As Variant) + Call _PropertySet("OnApproveSubmit", pvValue) +End Property ' OnApproveSubmit (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnConfirmDelete() As Variant + OnConfirmDelete = _PropertyGet("OnConfirmDelete") +End Property ' OnConfirmDelete (get) + +Property Let OnConfirmDelete(ByVal pvValue As Variant) + Call _PropertySet("OnConfirmDelete", pvValue) +End Property ' OnConfirmDelete (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnCursorMoved() As Variant + OnCursorMoved = _PropertyGet("OnCursorMoved") +End Property ' OnCursorMoved (get) + +Property Let OnCursorMoved(ByVal pvValue As Variant) + Call _PropertySet("OnCursorMoved", pvValue) +End Property ' OnCursorMoved (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' OnErrorOccurred (get) + +Property Let OnErrorOccurred(ByVal pvValue As Variant) + Call _PropertySet("OnErrorOccurred", pvValue) +End Property ' OnErrorOccurred (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnLoaded() As Variant + OnLoaded = _PropertyGet("OnLoaded") +End Property ' OnLoaded (get) + +Property Let OnLoaded(ByVal pvValue As Variant) + Call _PropertySet("OnLoaded", pvValue) +End Property ' OnLoaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloaded() As Variant + OnReloaded = _PropertyGet("OnReloaded") +End Property ' OnReloaded (get) + +Property Let OnReloaded(ByVal pvValue As Variant) + Call _PropertySet("OnReloaded", pvValue) +End Property ' OnReloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnReloading() As Variant + OnReloading = _PropertyGet("OnReloading") +End Property ' OnReloading (get) + +Property Let OnReloading(ByVal pvValue As Variant) + Call _PropertySet("OnReloading", pvValue) +End Property ' OnReloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnResetted() As Variant + OnResetted = _PropertyGet("OnResetted") +End Property ' OnResetted (get) + +Property Let OnResetted(ByVal pvValue As Variant) + Call _PropertySet("OnResetted", pvValue) +End Property ' OnResetted (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnRowChanged() As Variant + OnRowChanged = _PropertyGet("OnRowChanged") +End Property ' OnRowChanged (get) + +Property Let OnRowChanged(ByVal pvValue As Variant) + Call _PropertySet("OnRowChanged", pvValue) +End Property ' OnRowChanged (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloaded() As Variant + OnUnloaded = _PropertyGet("OnUnloaded") +End Property ' OnUnloaded (get) + +Property Let OnUnloaded(ByVal pvValue As Variant) + Call _PropertySet("OnUnloaded", pvValue) +End Property ' OnUnloaded (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OnUnloading() As Variant + OnUnloading = _PropertyGet("OnUnloading") +End Property ' OnUnloading (get) + +Property Let OnUnloading(ByVal pvValue As Variant) + Call _PropertySet("OnUnloading", pvValue) +End Property ' OnUnloading (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant +' Return either an error or an object of type OPTIONGROUP based on its name + +Const cstThisSub = "SubForm.OptionGroup" +Dim ogGroup As Object + Utils._SetCalledSub(cstThisSub) + If IsMissing(pvGroupName) Then Call _TraceArguments() + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, ParentComponent, DatabaseForm) + If Not IsNull(ogGroup) Then + ogGroup._DocEntry = _DocEntry + ogGroup._DbEntry = _DbEntry + End If + Set OptionGroup = ogGroup + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' OptionGroup V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderBy() As Variant + OrderBy = _PropertyGet("OrderBy") +End Property ' OrderBy (get) V1.2.0 + +Property Let OrderBy(ByVal pvValue As Variant) + Call _PropertySet("OrderBy", pvValue) +End Property ' OrderBy (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get OrderByOn() As Variant + OrderByOn = _PropertyGet("OrderByOn") +End Property ' OrderByOn (get) V1.2.0 + +Property Let OrderByOn(ByVal pvValue As Variant) + Call _PropertySet("OrderByOn", pvValue) +End Property ' OrderByOn (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Parent() As Object + + Utils._SetCalledSub("SubForm.getParent") + On Error Goto Error_Function + + Set Parent = _Parent + +Exit_Function: + Utils._ResetCalledSub("SubForm.getParent") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.getParent", Erl) + Set Parent = Nothing + GoTo Exit_Function +End Function ' Parent + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Recordset() As Object + Recordset = _PropertyGet("Recordset") +End Property ' Recordset (get) V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get RecordSource() As Variant + RecordSource = _PropertyGet("RecordSource") +End Property ' RecordSource (get) + +Property Let RecordSource(ByVal pvValue As Variant) + Call _PropertySet("RecordSource", pvValue) +End Property ' RecordSource (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Controls(Optional ByVal pvIndex As Variant) As Variant +' Return a Control object with name or index = pvIndex + +If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("SubForm.Controls") + +Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String +Dim j As Integer + + Set ocControl = Nothing + iControlCount = DatabaseForm.getCount() + + If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + oCounter._Parent = _This + oCounter._Count = iControlCount + Set Controls = oCounter + Goto Exit_Function + End If + + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + + ' Start building the ocControl object + ' Determine exact name + Set ocControl = New Control + Set ocControl._This = ocControl + Set ocControl._Parent = _This + ocControl._ParentType = CTLPARENTISSUBFORM + sParentShortcut = _Shortcut + sControls() = DatabaseForm.getElementNames() + + Select Case VarType(pvIndex) + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index + ocControl._Name = sControls(pvIndex) + Case vbString ' Check control name validity (non case sensitive) + bFound = False + sIndex = UCase(Utils._Trim(pvIndex)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sIndex Then + bFound = True + Exit For + End If + Next i + If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + End Select + + With ocControl + ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) + Set .ControlModel = DatabaseForm.getByName(._Name) + ._ImplementationName = .ControlModel.getImplementationName() + ._FormComponent = ParentComponent + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + If ._ClassId > 0 And ._ClassId <> acHiddenControl Then + Set .ControlView = ParentComponent.CurrentController.getControl(.ControlModel) + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With + Set Controls = ocControl + +Exit_Function: + Utils._ResetCalledSub("SubForm.Controls") + Exit Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set Controls = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) + Set Controls = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Controls", Erl) + Set Controls = Nothing + GoTo Exit_Function +End Function ' Controls V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("SubForm.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("SubForm.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Refresh() As Boolean +' Refresh data with its most recent value in the database in a form or subform + Utils._SetCalledSub("SubForm.Refresh") + If _ErrorHandler() Then On Local Error Goto Error_Function + Refresh = False + +Dim oSet As Object + Set oSet = DatabaseForm.createResultSet() + If Not IsNull(oSet) Then + oSet.refreshRow() + Refresh = True + End If + +Exit_Function: + Set oSet = Nothing + Utils._ResetCalledSub("SubForm.Refresh") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl) + GoTo Exit_Function +End Function ' Refresh + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Requery() As Boolean +' Refresh data displayed in a form, subform, combobox or listbox + Utils._SetCalledSub("SubForm.Requery") + If _ErrorHandler() Then On Local Error Goto Error_Function + Requery = False + + DatabaseForm.reload() + Requery = True + +Exit_Function: + Utils._ResetCalledSub("SubForm.Requery") + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm.Requery", Erl) + GoTo Exit_Function +End Function ' Requery + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("SubForm.setProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("SubForm.setProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private Function _GetListener(ByVal psProperty As String) As String +' Return the X...Listener corresponding with the property in argument + + Select Case UCase(psProperty) + Case UCase("OnApproveCursorMove") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveParameter") + _GetListener = "XDatabaseParameterListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveRowChange") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveSubmit") + _GetListener = "XSubmitListener" + Case UCase("OnConfirmDelete") + _GetListener = "XConfirmDeleteListener" + Case UCase("OnCursorMoved"), UCase("OnRowChanged") + _GetListener = "XRowSetListener" + Case UCase("OnErrorOccurred") + _GetListener = "XSQLErrorListener" + Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") + _GetListener = "XLoadListener" + End Select + +End Function ' _GetListener V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + + _PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "CurrentRecord" _ + , "Filter", "FilterOn", "LinkChildFields", "LinkMasterFields", "Name" _ + , "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _ + , "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _ + , "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _ + , "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OrderBy" _ + , "OrderByOn", "Parent", "RecordSource" _ + ) ' Recordset removed + +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("SubForm.get" & psProperty) +Dim iArgNr As Integer + If Not IsMissing(pvIndex) Then + Select Case UCase(_A2B_.CalledSub) + Case UCase("getProperty") : iArgNr = 3 + Case UCase("SubForm.getProperty") : iArgNr = 2 + Case UCase("SubForm.get" & psProperty) : iArgNr = 1 + End Select + If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function + End If + +'Execute +Dim oDatabase As Object, vBookmark As Variant, oObject As Object + _PropertyGet = EMPTY + + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + _PropertyGet = DatabaseForm.AllowInserts + Case UCase("AllowDeletions") + _PropertyGet = DatabaseForm.AllowDeletes + Case UCase("AllowEdits") + _PropertyGet = DatabaseForm.AllowUpdates + Case UCase("CurrentRecord") + _PropertyGet = DatabaseForm.Row + Case UCase("Filter") + _PropertyGet = DatabaseForm.Filter + Case UCase("FilterOn") + _PropertyGet = DatabaseForm.ApplyFilter + Case UCase("LinkChildFields") + If Utils._hasUNOProperty(DatabaseForm, "DetailFields") Then + If IsMissing(pvIndex) Then + _PropertyGet = DatabaseForm.DetailFields + Else + If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.DetailFields) Then Goto trace_Error_Index + _PropertyGet = DatabaseForm.DetailFields(pvIndex) + End If + End If + Case UCase("LinkMasterFields") + If Utils._hasUNOProperty(DatabaseForm, "MasterFields") Then + If IsMissing(pvIndex) Then + _PropertyGet = DatabaseForm.MasterFields + Else + If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.MasterFields) Then Goto trace_Error_Index + _PropertyGet = DatabaseForm.MasterFields(pvIndex) + End If + End If + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + _PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name) + Case UCase("OrderBy") + _PropertyGet = _OrderBy + Case UCase("OrderByOn") + If DatabaseForm.Order = "" Then _PropertyGet = False Else _PropertyGet = True + Case UCase("Parent") ' Only for indirect access from property object + _PropertyGet = Parent + Case UCase("Recordset") + If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? + Set oObject = New Recordset + With DatabaseForm + Set oObject._This = oObject + oObject._CommandType = .CommandType + oObject._Command = .Command + oObject._ParentName = _Name + oObject._ParentType = _Type + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Set oObject._ParentDatabase = oDatabase + Set oObject._ParentDatabase.Connection = .ActiveConnection + oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) + oObject._PassThrough = ( .EscapeProcessing = False ) + oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) + Call oObject._Initialize() + End With + With oDatabase + .RecordsetMax = .RecordsetMax + 1 + oObject._Name = Format(.RecordsetMax, "0000000") + .RecordsetsColl.Add(oObject, UCase(oObject._Name)) + End With + Set _PropertyGet = oObject + Case UCase("RecordSource") + _PropertyGet = DatabaseForm.Command + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("SubForm.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = EMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm._PropertyGet", Erl) + _PropertyGet = EMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("SubForm.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "SubForm.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("AllowAdditions") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.AllowInserts = pvValue + DatabaseForm.reload() + Case UCase("AllowDeletions") + If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.AllowDeletes = pvValue + DatabaseForm.reload() + Case UCase("AllowEdits") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.AllowUpdates = pvValue + DatabaseForm.reload() + Case UCase("CurrentRecord") + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + DatabaseForm.absolute(pvValue) + Case UCase("Filter") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("FilterOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + DatabaseForm.ApplyFilter = pvValue + DatabaseForm.reload() + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Not Utils._RegisterEventScript(DatabaseForm _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue, _Name _ + ) Then GoTo Trace_Error + Case UCase("OrderBy") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + _OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + Case UCase("OrderByOn") + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = "" + DatabaseForm.reload() + Case UCase("RecordSource") + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) + DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND + DatabaseForm.Filter = "" + DatabaseForm.reload() + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("SubForm.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "SubForm._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/TempVar.xba b/wizards/source/access2base/TempVar.xba new file mode 100644 index 000000000..d600de3b2 --- /dev/null +++ b/wizards/source/access2base/TempVar.xba @@ -0,0 +1,195 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be TEMPVAR +Private _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _Value As Variant + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJTEMPVAR + Set _This = Nothing + Set _Parent = Nothing + _Name = "" + _Value = Null +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Terminate() + On Local Error Resume Next + Call Class_Initialize() +End Sub ' Destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub Dispose() + Call Class_Terminate() +End Sub ' Explicit destructor + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS GET/LET/SET PROPERTIES --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Get Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("TempVar.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("TempVar.getProperty") + +End Function ' getProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean +' Return True if object has a valid property called pvProperty (case-insensitive comparison !) + + If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) + Exit Function + +End Function ' hasProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Properties(ByVal Optional pvIndex As Variant) As Variant +' Return +' a Collection object if pvIndex absent +' a Property object otherwise + +Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String + vPropertiesList = _PropertiesList() + sObject = Utils._PCase(_Type) + If IsMissing(pvIndex) Then + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK + Utils._SetCalledSub("TempVar.getProperty") + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub("TempVar.getProperty") +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Name", "ObjectType", "Value") +End Function ' _PropertiesList + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertyGet(ByVal psProperty As String) As Variant +' Return property value of the psProperty property name + + If _ErrorHandler() Then On Local Error Goto Error_Function + Utils._SetCalledSub("TempVar.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + _PropertyGet = _Value + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("TempVar.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "TempVar._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("TempVar.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer + + If _IsLeft(_A2B_.CalledSub, "TempVar.") Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("Value") + _Value = pvValue + _A2B_.TempVars.Item(UCase(_Name)).Value = pvValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("TempVar.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "TempVar._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet + + \ No newline at end of file diff --git a/wizards/source/access2base/Test.xba b/wizards/source/access2base/Test.xba new file mode 100644 index 000000000..7ad95904e --- /dev/null +++ b/wizards/source/access2base/Test.xba @@ -0,0 +1,14 @@ + + +Option Explicit +'Option Compatible + +Sub Main +Dim a, b() + _ErrorHandler(False) +' DebugPrint vbLF +' TraceConsole() + exit sub +End Sub + + \ No newline at end of file diff --git a/wizards/source/access2base/Trace.xba b/wizards/source/access2base/Trace.xba new file mode 100644 index 000000000..041bea532 --- /dev/null +++ b/wizards/source/access2base/Trace.xba @@ -0,0 +1,438 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +Public Const cstLogMaxEntries = 99 + +REM Typical Usage +REM TraceLog("INFO", "The OK button was pressed") +REM +REM Typical Usage for error logging +REM Sub MySub() +REM On Local Error GoTo Error_Sub +REM ... +REM Exit_Sub: +REM Exit Sub +REM Error_Sub: +REM TraceError("ERROR", Err, "MySub", Erl) +REM GoTo Exit_Sub +REM End Sub +REM +REM To display the current logged traces and/or to set parameters +REM TraceConsole() + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceConsole() +' Display the Trace dialog with current trace log values and parameter choices + If _ErrorHandler() Then On Local Error Goto Error_Sub + +Dim sLineBreak As String, oTraceDialog As Object + sLineBreak = vbNewLine + + Set oTraceDialog = CreateUnoDialog(Utils._GetDialogLib().dlgTrace) + oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE") + oTraceDialog.Model.HelpText = _GetLabel("DLGTRACE_HELP") + +Dim oEntries As Object, oTraceLog As Object, oClear As Object, oMinLevel As Object, oNbEntries As Object, oDump As Object +Dim oControl As Object +Dim i As Integer, sText As String, iOKCancel As Integer + + Set oNbEntries = oTraceDialog.Model.getByName("numNbEntries") + oNbEntries.Value = _A2B_.TraceLogCount + oNbEntries.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblNbEntries") + oControl.Label = _GetLabel("DLGTRACE_LBLNBENTRIES_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP") + + Set oEntries = oTraceDialog.Model.getByName("numEntries") + If _A2B_.TraceLogMaxEntries = 0 Then _A2B_.TraceLogMaxEntries = cstLogMaxEntries + oEntries.Value = _A2B_.TraceLogMaxEntries + oEntries.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblEntries") + oControl.Label = _GetLabel("DLGTRACE_LBLENTRIES_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP") + + Set oDump = oTraceDialog.Model.getByName("cmdDump") + oDump.Enabled = 0 + oDump.Label = _GetLabel("DLGTRACE_CMDDUMP_LABEL") + oDump.HelpText = _GetLabel("DLGTRACE_CMDDUMP_HELP") + + Set oTraceLog = oTraceDialog.Model.getByName("txtTraceLog") + oTraceLog.HelpText = _GetLabel("DLGTRACE_TXTTRACELOG_HELP") + If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized + oTraceLog.HardLineBreaks = True + sText = "" + If _A2B_.TraceLogCount > 0 Then + If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast + Do + If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0 + If Len(_A2B_.TraceLogs(i)) > 11 Then + sText = sText & Right(_A2B_.TraceLogs(i), Len(_A2B_.TraceLogs(i)) - 11) & sLineBreak ' Skip date in display + End If + Loop While i <> _A2B_.TraceLogLast + oDump.Enabled = 1 ' Enable DumpToFile only if there is something to dump + End If + If Len(sText) > 0 Then sText = Left(sText, Len(sText) - Len(sLineBreak)) ' Skip last linefeed + oTraceLog.Text = sText + Else + oTraceLog.Text = _GetLabel("DLGTRACE_TXTTRACELOG_TEXT") + End If + + Set oClear = oTraceDialog.Model.getByName("chkClear") + oClear.State = 0 ' Unchecked + oClear.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblClear") + oControl.Label = _GetLabel("DLGTRACE_LBLCLEAR_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP") + + Set oMinLevel = oTraceDialog.Model.getByName("cboMinLevel") + If _A2B_.MinimalTraceLevel = 0 Then _A2B_.MinimalTraceLevel = _TraceLevel(TRACEERRORS) + oMinLevel.Text = _TraceLevel(_A2B_.MinimalTraceLevel) + oMinLevel.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP") + + Set oControl = oTraceDialog.Model.getByName("lblMinLevel") + oControl.Label = _GetLabel("DLGTRACE_LBLMINLEVEL_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP") + + Set oControl = oTraceDialog.Model.getByName("cmdOK") + oControl.Label = _GetLabel("DLGTRACE_CMDOK_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_CMDOK_HELP") + + Set oControl = oTraceDialog.Model.getByName("cmdCancel") + oControl.Label = _GetLabel("DLGTRACE_CMDCANCEL_LABEL") + oControl.HelpText = _GetLabel("DLGTRACE_CMDCANCEL_HELP") + + iOKCancel = oTraceDialog.Execute() + + Select Case iOKCancel + Case 1 ' OK + If oClear.State = 1 Then + _A2B_.TraceLogs() = Array() ' Erase logged traces + _A2B_.TraceLogCount = 0 + End If + If oMinLevel.Text <> "" Then _A2B_.MinimalTraceLevel = _TraceLevel(oMinLevel.Text) + If oEntries.Value <> 0 And oEntries.Value <> _A2B_.TraceLogMaxEntries Then + _A2B_.TraceLogs() = Array() + _A2B_.TraceLogMaxEntries = oEntries.Value + End If + Case 0 ' Cancel + Case Else + End Select + +Exit_Sub: + If Not IsNull(oTraceDialog) Then oTraceDialog.Dispose() + Exit Sub +Error_Sub: + With _A2B_ + .TraceLogs() = Array() + .TraceLogCount = 0 + .TraceLogLast = 0 + End With + GoTo Exit_Sub +End Sub ' TraceConsole V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceError(ByVal psErrorLevel As String _ + , ByVal piErrorCode As Integer _ + , ByVal psErrorProc As String _ + , ByVal piErrorLine As Integer _ + , ByVal Optional pvMsgBox As Variant _ + , ByVal Optional pvArgs As Variant _ + ) +' Store error code and description in trace rolling buffer +' Display error message if errorlevel >= ERROR +' Stop program execution if errorlevel = FATAL or ABORT + + On Local Error Resume Next + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session + +Dim sErrorText As String, sErrorDesc As String, oDb As Object, bMsgBox As Boolean + sErrorDesc = _ErrorMessage(piErrorCode, pvArgs) + sErrorText = _GetLabel("ERR#") & CStr(piErrorCode) _ + & " (" & sErrorDesc & ") " & _GetLabel("ERROCCUR") _ + & Iif(piErrorLine > 0, " " & _GetLabel("ERRLINE") & " " & CStr(piErrorLine), "") _ + & Iif(psErrorProc <> "", " " & _GetLabel("ERRIN") & " " & psErrorProc, Iif(_A2B_.CalledSub = "", "", " " & _Getlabel("ERRIN") & " " & _A2B_.CalledSub)) + With _A2B_ + .LastErrorCode = piErrorCode + .LastErrorLevel = psErrorLevel + .ErrorText = sErrorDesc + .ErrorLongText = sErrorText + .CalledSub = "" + End With + If VarType(pvMsgBox) = vbError Then + bMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT ) + ElseIf IsMissing(pvMsgBox) Then + bMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT ) + Else + bMsgBox = pvMsgBox + End If + TraceLog(psErrorLevel, sErrorText, bMsgBox) + + ' Unexpected error detected in user program or in Access2Base + If psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT Then + If psErrorLevel = TRACEFATAL Then + Set oDb = _A2B_.CurrentDb() + If Not IsNull(oDb) Then oDb.CloseAllrecordsets() + End If + Stop + End If + +End Sub ' TraceError V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TraceErrorCode() As Variant +' Return the last encountered error code, level, description in an array +' UNPUBLISHED + +Dim vError As Variant + + With _A2B_ + vError = Array( _ + .LastErrorCode _ + , .LastErrorLevel _ + , .ErrorText _ + , .ErrorLongText _ + ) + End With + TraceErrorCode = vError + +End Function ' TraceErrorCode V6.3 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceLevel(ByVal Optional psTraceLevel As String) +' Set trace level to argument + + If _ErrorHandler() Then On Local Error Goto Error_Sub + Select Case True + Case IsMissing(psTraceLevel) : psTraceLevel = "ERROR" + Case psTraceLevel = "" : psTraceLevel = "ERROR" + Case Utils._InList(UCase(psTraceLevel), Array( _ + TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT _ + )) + Case Else : Goto Exit_Sub + End Select + _A2B_.MinimalTraceLevel = _TraceLevel(psTraceLevel) + +Exit_Sub: + Exit Sub +Error_Sub: + With _A2B_ + .TraceLogs() = Array() + .TraceLogCount = 0 + .TraceLogLast = 0 + End With + GoTo Exit_Sub +End Sub ' TraceLevel V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub TraceLog(ByVal psTraceLevel As String _ + , ByVal psText As String _ + , ByVal Optional pbMsgBox As Boolean _ + ) +' Store Text in trace log (circular buffer) + + If _ErrorHandler() Then On Local Error Goto Error_Sub +Dim vTraceLogs() As String, sTraceLevel As String + + With _A2B_ + If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) + If _TraceLevel(psTraceLevel) < .MinimalTraceLevel Then Exit Sub + + If UBound(.TraceLogs) = -1 Then ' Initialize TraceLog + If .TraceLogMaxEntries = 0 Then .TraceLogMaxEntries = cstLogMaxEntries + + Redim vTraceLogs(0 To .TraceLogMaxEntries - 1) + .TraceLogs = vTraceLogs + .TraceLogCount = 0 + .TraceLogLast = -1 + If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) ' Set default value + End If + + .TraceLogLast = .TraceLogLast + 1 + If .TraceLogLast > UBound(.TraceLogs) Then .TraceLogLast = LBound(.TraceLogs) ' Circular buffer + If Len(psTraceLevel) > 7 Then sTraceLevel = Left(psTraceLevel, 7) Else sTraceLevel = psTraceLevel & Spc(8 - Len(psTraceLevel)) + .TraceLogs(.TraceLogLast) = Format(Now(), "YYYY-MM-DD hh:mm:ss") & " " & sTraceLevel & psText + If .TraceLogCount <= UBound(.TraceLogs) Then .TraceLogCount = .TraceLogCount + 1 ' # of active entries + End With + + If IsMissing(pbMsgBox) Then pbMsgBox = True +Dim iMsgBox As Integer + If pbMsgBox Then + Select Case psTraceLevel + Case TRACEINFO: iMsgBox = vbInformation + Case TRACEERRORS, TRACEWARNING: iMsgBox = vbExclamation + Case TRACEFATAL, TRACEABORT: iMsgBox = vbCritical + Case Else: iMsgBox = vbInformation + End Select + MsgBox psText, vbOKOnly + iMsgBox, psTraceLevel + End If + +Exit_Sub: + Exit Sub +Error_Sub: + With _A2B_ + .TraceLogs() = Array() + .TraceLogCount = 0 + .TraceLogLast = 0 + End With + GoTo Exit_Sub +End Sub ' TraceLog V0.9.5 + + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private Sub _DumpToFile(oEvent As Object) +' Execute the Dump To File command from the Trace dialog +' Modified from Andrew Pitonyak's Base Macro Programming §10.4 + + + If _ErrorHandler() Then On Local Error GoTo Error_Sub + +Dim sPath as String, iFileNumber As Integer, i As Integer + + sPath = _PromptFilePicker("txt") + If sPath <> "" Then ' Save button pressed + If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized + iFileNumber = FreeFile() + Open sPath For Append Access Write Lock Read As iFileNumber + If _A2B_.TraceLogCount > 0 Then + If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast + Do + If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0 + Print #iFileNumber _A2B_.TraceLogs(i) + Loop While i <> _A2B_.TraceLogLast + End If + Close iFileNumber + MsgBox _GetLabel("SAVECONSOLEENTRIES"), vbOK + vbInformation, _GetLabel("SAVECONSOLE") + End If + End If + +Exit_Sub: + Exit Sub +Error_Sub: + TraceError("ERROR", Err, "DumpToFile", Erl) + GoTo Exit_Sub +End Sub ' DumpToFile V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ErrorHandler(Optional ByVal pbCheck As Boolean) As Boolean +' Indicate if error handler is activated or not +' When argument present set error handler + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session + If Not IsMissing(pbCheck) Then _A2B_.ErrorHandler = pbCheck + _ErrorHandler = _A2B_.ErrorHandler + Exit Function +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _ErrorMessage(ByVal piErrorNumber As Integer, Optional ByVal pvArgs As Variant) As String +' Return error message corresponding to ErrorNumber (standard or not) +' and replaces %0, %1, ... , %9 by psArgs(0), psArgs(1), ... + +Dim sErrorMessage As String, i As Integer, sErrLabel + _ErrorMessage = "" + If piErrorNumber > ERRINIT Then + sErrLabel = "ERR" & piErrorNumber + sErrorMessage = _Getlabel(sErrLabel) + If Not IsMissing(pvArgs) Then + If Not IsArray(pvArgs) Then + sErrorMessage = Join(Split(sErrorMessage, "%0"), Utils._CStr(pvArgs, False)) + Else + For i = LBound(pvArgs) To UBound(pvArgs) + sErrorMessage = Join(Split(sErrorMessage, "%" & i), Utils._CStr(pvArgs(i), False)) + Next i + End If + End If + Else + sErrorMessage = Error(piErrorNumber) + ' Most (or all?) error messages terminate with a "." + If Len(sErrorMessage) > 1 And Right(sErrorMessage, 1) = "." Then sErrorMessage = Left(sErrorMessage, Len(sErrorMessage)-1) + End If + + _ErrorMessage = sErrorMessage + Exit Function + +End Function ' ErrorMessage V0.8.9 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _PromptFilePicker(ByVal psSuffix As String) As String +' Prompt for output file name +' Return "" if Cancel +' Modified from Andrew Pitonyak's Base Macro Programming §10.4 + + If _ErrorHandler() Then On Local Error GoTo Error_Function + +Dim oFileDialog as Object, oUcb as object, oPath As Object +Dim iAccept as Integer, sInitPath as String + + Set oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") + oFileDialog.Initialize(Array(com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION)) + Set oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + + oFileDialog.appendFilter("*." & psSuffix, "*." & psSuffix) + oFileDialog.appendFilter("*.*", "*.*") + oFileDialog.setCurrentFilter("*." & psSuffix) + Set oPath = createUnoService("com.sun.star.util.PathSettings") + sInitPath = oPath.Work ' Probably My Documents + If oUcb.Exists(sInitPath) Then oFileDialog.SetDisplayDirectory(sInitPath) + + iAccept = oFileDialog.Execute() + + _PromptFilePicker = "" + If iAccept = 1 Then ' Save button pressed + _PromptFilePicker = oFileDialog.Files(0) + End If + +Exit_Function: + If Not IsEmpty(oFileDialog) And Not IsNull(oFileDialog) Then oFileDialog.Dispose() + Exit Function +Error_Function: + TraceError("ERROR", Err, "PromptFilePicker", Erl) + GoTo Exit_Function +End Function ' PromptFilePicker V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _TraceArguments(Optional psCall As String) +' Process the ERRMISSINGARGUMENTS error +' psCall is present if error detected before call to _SetCalledSub + + If Not IsMissing(psCall) Then Utils._SetCalledSub(psCall) + TraceError(TRACEFATAL, ERRMISSINGARGUMENTS, Utils._CalledSub(), 0) + Exit Sub + +End Sub ' TraceArguments + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _TraceLevel(ByVal pvTraceLevel As Variant) As Variant +' Convert string trace level to numeric value or the opposite + +Dim vTraces As Variant, i As Integer + vTraces = Array(TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT, TRACEANY) + + Select Case VarType(pvTraceLevel) + Case vbString + _TraceLevel = 4 ' 4 = Default + For i = 0 To UBound(vTraces) + If UCase(pvTraceLevel) = UCase(vTraces(i)) Then + _TraceLevel = i + 1 + Exit For + End If + Next i + Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal + If pvTraceLevel < 1 Or pvTraceLevel > UBound(vTraces) + 1 Then _TraceLevel = TRACEERRORS Else _TraceLevel = vTraces(pvTraceLevel - 1) + End Select + +End Function ' TraceLevel + + diff --git a/wizards/source/access2base/UtilProperty.xba b/wizards/source/access2base/UtilProperty.xba new file mode 100644 index 000000000..9f7ee4821 --- /dev/null +++ b/wizards/source/access2base/UtilProperty.xba @@ -0,0 +1,331 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +'********************************************************************** +' UtilProperty module +' +' Module of utilities to manipulate arrays of PropertyValue's. +'********************************************************************** + +'********************************************************************** +' Copyright (c) 2003-2004 Danny Brewer +' d29583@groovegarden.com +'********************************************************************** + +'********************************************************************** +' If you make changes, please append to the change log below. +' +' Change Log +' Danny Brewer Revised 2004-02-25-01 +' Jean-Pierre Ledure Adapted to Access2Base coding conventions +' PropValuesToStr rewritten and addition of StrToPropValues +' Bug corrected on date values +' Addition of support of 2-dimensional arrays +' Support of empty arrays to allow JSON conversions +'********************************************************************** + +Option Explicit + +Private Const cstHEADER = "### PROPERTYVALUES ###" +Private Const cstEMPTYARRAY = "### EMPTY ARRAY ###" + +REM ======================================================================================================================= +Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue +' Create and return a new com.sun.star.beans.PropertyValue. + +Dim oPropertyValue As New com.sun.star.beans.PropertyValue + + If Not IsMissing(psName) Then oPropertyValue.Name = psName + If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue) + _MakePropertyValue() = oPropertyValue + +End Function ' _MakePropertyValue V1.3.0 + +REM ======================================================================================================================= +Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant +' Date BASIC variables give error. Change them to strings +' Empty arrays should be replaced by cstEMPTYARRAY + + If VarType(pvValue) = vbDate Then + _CheckPropertyValue = Utils._CStr(pvValue, False) + ElseIf IsArray(pvValue) Then + If UBound(pvValue, 1) < LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue + Else + _CheckPropertyValue = pvValue + End If + +End Function ' _CheckPropertyValue + +REM ======================================================================================================================= +Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer +' Return the number of PropertyValue's in an array. +' Parameters: +' pvPropertyValuesArray - an array of PropertyValue's, that is an array of com.sun.star.beans.PropertyValue. +' Returns zero if the array contains no elements. + +Dim iNumProperties As Integer + If Not IsArray(pvPropertyValuesArray) Then iNumProperties = 0 Else iNumProperties = UBound(pvPropertyValuesArray) + 1 + _NumPropertyValues() = iNumProperties + +End Function ' _NumPropertyValues V1.3.0 + +REM ======================================================================================================================= +Public Function _FindPropertyIndex(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String ) As Integer +' Find a particular named property from an array of PropertyValue's. +' Finds the index in the array of PropertyValue's and returns it, or returns -1 if it was not found. + +Dim iNumProperties As Integer, i As Integer, vProp As Variant + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + For i = 0 To iNumProperties - 1 + vProp = pvPropertyValuesArray(i) + If UCase(vProp.Name) = UCase(psPropName) Then + _FindPropertyIndex() = i + Exit Function + EndIf + Next i + _FindPropertyIndex() = -1 + +End Function ' _FindPropertyIndex V1.3.0 + +REM ======================================================================================================================= +Public Function _FindProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) As com.sun.star.beans.PropertyValue +' Find a particular named property from an array of PropertyValue's. +' Finds the PropertyValue and returns it, or returns Null if not found. + +Dim iPropIndex As Integer, vProp As Variant + iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName) + If iPropIndex >= 0 Then + vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript + _FindProperty() = vProp + EndIf + +End Function ' _FindProperty V1.3.0 + +REM ======================================================================================================================= +Public Function _GetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, Optional pvDefaultValue) As Variant +' Get the value of a particular named property from an array of PropertyValue's. +' vDefaultValue - This value is returned if the property is not found in the array. + +Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Variant, i As Integer, j As Integer + iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName) + If iPropIndex >= 0 Then + vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript + vValue = vProp.Value ' get the value from the PropertyValue + If VarType(vValue) = vbString Then + If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue + ElseIf IsArray(vValue) Then + If IsArray(vValue(0)) Then ' Array of arrays + vMatrix = Array() + ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0))) + For i = 0 To UBound(vValue) + For j = 0 To UBound(vValue(0)) + vMatrix(i, j) = vValue(i)(j) + Next j + Next i + _GetPropertyValue() = vMatrix + Else + _GetPropertyValue() = vValue ' Simple vector OK + End If + Else + _GetPropertyValue() = vValue + End If + Else + If IsMissing(pvDefaultValue) Then pvDefaultValue = Null + _GetPropertyValue() = pvDefaultValue + EndIf + +End Function ' _GetPropertyValue V1.3.0 + +REM ======================================================================================================================= +Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue As Variant) +' Set the value of a particular named property from an array of PropertyValue's. + +Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer + + iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName) + If iPropIndex >= 0 Then + ' Found, the PropertyValue is already in the array. Just modify its value. + vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript + vProp.Value = _CheckPropertyValue(pvValue) ' set the property value. + pvPropertyValuesArray(iPropIndex) = vProp ' put it back into array + Else + ' Not found, the array contains no PropertyValue with this name. Append new element to array. + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + If iNumProperties = 0 Then + pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue)) + Else + ' Make array larger. + Redim Preserve pvPropertyValuesArray(iNumProperties) + ' Assign new PropertyValue + pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue) + EndIf + EndIf + +End Sub ' _SetPropertyValue V1.3.0 + +REM ======================================================================================================================= +Public Sub _DeleteProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) +' Delete a particular named property from an array of PropertyValue's. + +Dim iPropIndex As Integer + iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName) + If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex) + +End Sub ' _DeletePropertyValue V1.3.0 + +REM ======================================================================================================================= +Public Sub _DeleteIndexedProperty(ByRef pvPropertyValuesArray As Variant, ByVal piPropIndex As Integer) +' Delete a particular indexed property from an array of PropertyValue's. + +Dim iNumProperties As Integer, i As Integer + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + + ' Did we find it? + If piPropIndex < 0 Then + ' Do nothing + ElseIf iNumProperties = 1 Then + ' Just return a new empty array + pvPropertyValuesArray = Array() + Else + ' If it is NOT the last item in the array, then shift other elements down into it's position. + If piPropIndex < iNumProperties - 1 Then + ' Bump items down lower in the array. + For i = piPropIndex To iNumProperties - 2 + pvPropertyValuesArray(i) = pvPropertyValuesArray(i + 1) + Next i + EndIf + ' Redimension the array to have one fewer element. + Redim Preserve pvPropertyValuesArray(iNumProperties - 2) + EndIf + +End Sub ' _DeleteIndexedProperty V1.3.0 + +REM ======================================================================================================================= +Public Function _PropValuesToStr(ByRef pvPropertyValuesArray As Variant) As String +' Return a string with dumped content of the array of PropertyValue's. +' SYNTAX: +' NameOfProperty = This is a string (or 12 or 2016-12-31 12:05 or 123.45 or -0.12E-05 ...) +' NameOfArray = (10) +' 1;2;3;4;5;6;7;8;9;10 +' NameOfMatrix = (2,10) +' 1;2;3;4;5;6;7;8;9;10 +' A;B;C;D;E;F;G;H;I;J +' Semicolons and backslashes are escaped with a backslash (see _CStr and _CVar functions) + +Dim iNumProperties As Integer, sResult As String, i As Integer, j As Integer, vProp As Variant +Dim sName As String, vValue As Variant, iType As Integer +Dim cstLF As String + + cstLF = vbLf() + iNumProperties = _NumPropertyValues(pvPropertyValuesArray) + + sResult = cstHEADER & cstLF + For i = 0 To iNumProperties - 1 + vProp = pvPropertyValuesArray(i) + sName = vProp.Name + vValue = vProp.Value + iType = VarType(vValue) + Select Case iType + Case < vbArray ' Scalar + sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF + Case Else ' Vector or matrix + If uBound(vValue, 1) < 0 Then + sResult = sResult & sName & " = (0)" & cstLF + ' 1-dimension but vector of vectors must also be considered + ElseIf VarType(vValue(0)) >= vbArray Then + sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF + For j = 0 To UBound(vValue) + sResult = sResult & Utils._CStr(vValue(j), False) & cstLF + Next j + Else + sResult = sResult & sName & " = (" & UBound(vValue, 1) + 1 & ")" & cstLF + sResult = sResult & Utils._CStr(vValue, False) & cstLF + End If + End Select + Next i + + _PropValuesToStr() = Left(sResult, Len(sResult) - 1) ' Remove last LF + +End Function ' _PropValuesToStr V1.3.0 + +REM ======================================================================================================================= +Public Function _StrToPropValues(psString) As Variant +' Return an array of PropertyValue's rebuilt from the string parameter + +Dim vString() As Variant, i As Integer,iArray As Integer, iRows As Integer, iCols As Integer +Dim lPosition As Long, sName As String, vValue As Variant, vResult As Variant, sDim As String +Dim lSearch As Long +Dim cstLF As String +Const cstEqualArray = " = (", cstEqual = " = " + + cstLF = Chr(10) + _StrToPropValues = Array() + vResult = Array() + + If psString = "" Then Exit Function + vString = Split(psString, cstLF) + If UBound(vString) <= 0 Then Exit Function ' There must be at least one name-value pair + If vString(0) <> cstHEADER Then Exit Function ' Check origin + + iArray = -1 + For i = 1 To UBound(vString) + If vString(i) <> "" Then ' Skip empty lines + If iArray < 0 Then ' Not busy with array row + lPosition = 1 + sName = Utils._RegexSearch(vString(i), "^\b\w+\b", lPosition) ' Identifier + If sName = "" Then Exit Function + If InStr(vString(i), cstEqualArray) = lPosition + Len(sName) Then ' Start array processing + lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1 + sDim = Utils._RegexSearch(vString(i), "\([0-9]+\)", lSearch) ' e.g. (10) + If sDim = "(0)" Then ' Empty array + iRows = -1 + vValue = Array() + _SetPropertyValue(vResult, sName, vValue) + ElseIf sDim <> "" Then ' Vector with content + iCols = CInt(Mid(sDim, 2, Len(sDim) - 2)) + iRows = 0 + ReDim vValue(0 To iCols - 1) + iArray = 0 + Else ' Matrix with content + lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1 + sDim = Utils._RegexSearch(vString(i), "\([0-9]+,", lSearch) ' e.g. (10, + iRows = CInt(Mid(sDim, 2, Len(sDim) - 2)) + sDim = Utils._RegexSearch(vString(i), ",[0-9]+\)", lSearch) ' e.g. ,20) + iCols = CInt(Mid(sDim, 2, Len(sDim) - 2)) + ReDim vValue(0 To iRows - 1) + iArray = 0 + End If + ElseIf InStr(vString(i), cstEqual) = lPosition + Len(sName) Then + vValue = Utils._CVar(Mid(vString(i), Len(sName) + Len(cstEqual) + 1)) + _SetPropertyValue(vResult, sName, vValue) + Else + Exit Function + End If + Else ' Line is an array row + If iRows = 0 Then + vValue = Utils._CVar(vString(i), True) ' Keep dates as strings + iArray = -1 + _SetPropertyValue(vResult, sName, vValue) + Else + vValue(iArray) = Utils._CVar(vString(i), True) + If iArray < iRows - 1 Then + iArray = iArray + 1 + Else + iArray = -1 + _SetPropertyValue(vResult, sName, vValue) + End If + End If + End If + End If + Next i + + _StrToPropValues = vResult + +End Function + + \ No newline at end of file diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba new file mode 100644 index 000000000..7242c605b --- /dev/null +++ b/wizards/source/access2base/Utils.xba @@ -0,0 +1,1308 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +Global _A2B_ As Variant + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As Variant +'Add the item at the end of the array + +Dim vArray() As Variant + If IsArray(pvArray) Then vArray = pvArray Else vArray = Array() + ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1) + vArray(UBound(vArray)) = pvItem + _AddArray() = vArray() + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant +'Return on top of argument the list of all numeric types +'Facilitates the entry of the list of allowed types in _CheckArgument calls + +Dim i As Integer, vNewList() As Variant, vNumeric() As Variant, iSize As Integer + If IsMissing(pvTypes) Then + vNewList = Array() + ElseIf IsArray(pvTypes) Then + vNewList = pvTypes + Else + vNewList = Array(pvTypes) + End If + + vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal, vbBoolean) + + iSize = UBound(vNewlist) + ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1) + For i = 0 To UBound(vNumeric) + vNewList(iSize + i + 1) = vNumeric(i) + Next i + + _AddNumeric = vNewList + +End Function ' _AddNumeric V0.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function _BitShift(piValue As Integer, piConstant As Integer) As Boolean + + _BitShift = False + If piValue = 0 Then Exit Function + Select Case piConstant + Case 1 + Select Case piValue + Case 1, 3, 5, 7, 9, 11, 13, 15: _BitShift = True + Case Else + End Select + Case 2 + Select Case piValue + Case 2, 3, 6, 7, 10, 11, 14, 15: _BitShift = True + Case Else + End Select + Case 4 + Select Case piValue + Case 4, 5, 6, 7, 12, 13, 14, 15: _BitShift = True + Case Else + End Select + Case 8 + Select Case piValue + Case 8, 9, 10, 11, 12, 13, 14, 15: _BitShift = True + Case Else + End Select + End Select + +End Function ' BitShift + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CalledSub() As String + _CalledSub = Iif(_A2B_.CalledSub = "", "", _GetLabel("CALLTO") & " '" & _A2B_.CalledSub & "'") +End Function ' CalledSub V0.8.9 + + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CheckArgument(pvItem As Variant _ + , ByVal piArgNr As Integer _ + , ByVal pvType As Variant _ + , ByVal Optional pvValid As Variant _ + , ByVal Optional pvError As Boolean _ + ) As Variant +' Called by public functions to check the validity of their arguments +' pvItem Argument to be checked +' piArgNr Argument sequence number +' pvType Single value or array of allowed variable types +' If of string type must contain one or more valid pseudo-object types +' pvValid Single value or array of allowed values - comparison for strings is case-insensitive +' pvError If True (default), error handling in this routine. False in _setProperty methods in class modules. + + _CheckArgument = False + +Dim iVarType As Integer, bValidIsMissing As Boolean + If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType) + If iVarType = vbString Then ' pvType is a pseudo-type string + _CheckArgument = Utils._IsPseudo(pvItem, pvType) + Else + bValidIsMissing = ( VarType(pvValid) = vbError ) + If Not bValidIsMissing Then bValidIsMissing = IsMissing(pvValid) + If bValidIsMissing Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid) + End If + + If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem) + +Exit_Function: + If Not _CheckArgument Then + If IsMissing(pvError) Then pvError = True + If pvError Then + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(piArgNr, pvItem)) + End If + End If + Exit Function +End Function ' CheckArgument V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String +' Convert pvArg into a readable string (truncated if too long and pbShort = True or missing) +' pvArg may be a byte-array. Other arrays are processed recursively into a semicolon separated string + +Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long +Const cstLength = 50 +Const cstByteLength = 25 + + If IsMissing(pbShort) Then pbShort = True + If IsArray(pvArg) Then + sArg = "" + If VarType(pvArg) = vbByte Or VarType(pvArg) = vbArray + vbByte Then + If pbShort And UBound(pvArg) > cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg) + For i = 0 To iMax + sArg = sArg & Right("00" & Hex(pvArg(i)), 2) + Next i + Else + If pbShort Then + sArg = "[ARRAY]" + Else ' One-dimension arrays only + For i = LBound(pvArg) To UBound(pvArg) + sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call + Next i + If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1) + End If + End If + Else + Select Case VarType(pvArg) + Case vbEmpty : sArg = "[EMPTY]" + Case vbNull : sArg = "[NULL]" + Case vbObject + If IsNull(pvArg) Then + sArg = "[NULL]" + Else + sObject = Utils._ImplementationName(pvArg) + If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _ + , OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _ + , OBJDIALOG _ + )) Then + Set oArg = pvArg ' To avoid "Object variable not set" error message + sArg = "[" & oArg._Type & "] " & oArg._Name + ElseIf sObject <> "" Then + sArg = "[" & sObject & "]" + Else + sArg = "[OBJECT]" + End If + End If + Case vbVariant : sArg = "[VARIANT]" + Case vbString + ' Replace CR + LF by \n and HT by \t + ' Replace semicolon by \; to allow semicolon separated rows + sArg = Replace( _ + Replace( _ + Replace( _ + Replace( _ + Replace(pvArg, "\", "\\") _ + , Chr(13), "") _ + , Chr(10), "\n") _ + , Chr(9), "\t") _ + , ";", "\;") + Case vbBoolean : sArg = Iif(pvArg, "[TRUE]", "[FALSE]") + Case vbByte : sArg = Right("00" & Hex(pvArg), 2) + Case vbSingle, vbDouble, vbCurrency + sArg = Format(pvArg) + If InStr(UCase(sArg), "E") = 0 Then sArg = Format(pvArg, "##0.0##") + sArg = Replace(sArg, ",", ".") + Case vbBigint : sArg = CStr(CLng(pvArg)) + Case vbDate : sArg = Year(pvArg) & "-" & Right("0" & Month(pvArg), 2) & "-" & Right("0" & Day(pvArg), 2) _ + & " " & Right("0" & Hour(pvArg), 2) & ":" & Right("0" & Minute(pvArg), 2) _ + & ":" & Right("0" & Second(pvArg), 2) + Case Else : sArg = CStr(pvArg) + End Select + End If + If pbShort And Len(sArg) > cstLength Then + sLength = "(" & Len(sArg) & ")" + sArg = Left(sArg, cstLength - 5 - Len(slength)) & " ... " & sLength + End If + _CStr = sArg + +End Function ' CStr V0.9.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant +' psArg is presumed an output of _CStr (stored in the meantime in a text file f.i.) +' _CVar returns the corresponding original Variant variable or Null/Nothing if not possible +' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty +' pbStrDate = True keeps dates as strings + +Dim cstEscape1 As String, cstEscape2 As String + cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\ + cstEscape2 = Chr(27) ' ESC used as temporary escape character for \; + + _CVar = "" + If Len(psArg) = 0 Then Exit Function + +Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer + If IsMissing(pbStrDate) Then pbStrDate = False + sArg = Replace( _ + Replace( _ + Replace( _ + Replace(psArg, "\\", cstEscape1) _ + , "\;", cstEscape2) _ + , "\n", Chr(10)) _ + , "\t", Chr(9)) + + ' Semicolon separated string + vArgs = Split(sArg, ";") + If UBound(vArgs) > LBound(vArgs) Then ' Process each item recursively + vVars = Array() + Redim vVars(LBound(vArgs) To UBound(vArgs)) + For i = LBound(vVars) To UBound(vVars) + vVars(i) = _CVar(vArgs(i), pbStrDate) + Next i + _CVar = vVars + Exit Function + End If + + ' Usual case + Select Case True + Case sArg = "[EMPTY]" : _CVar = EMPTY + Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null + Case sArg = "[OBJECT]" : _CVar = Nothing + Case sArg = "[TRUE]" : _CVar = True + Case sArg = "[FALSE]" : _CVar = False + Case IsDate(sArg) + If pbStrDate Then _CVar = sArg Else _CVar = CDate(sArg) + Case IsNumeric(sArg) + If InStr(sArg, ".") > 0 Then + _CVar = Val(sArg) + Else + _CVar = CLng(Val(sArg)) ' Val always returns a double + End If + Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+(e[-+]?[0-9]+)?$") <> "" + _CVar = Val(sArg) ' Scientific notation + Case Else : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";") + End Select + +End Function ' CVar V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _DecimalPoint() As String +'Return locale decimal point + _DecimalPoint = Mid(Format(0, "0.0"), 2, 1) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _ExtensionLocation() As String +' Return the URL pointing to the location where OO installed the Access2Base extension +' Adapted from https://wiki.documentfoundation.org/Documentation/DevGuide/Extensions#Location_of_Installed_Extensions + +Dim oPip As Object, sLocation As String + Set oPip = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider") + _ExtensionLocation = oPip.getPackageLocation("Access2Base") + +End Function ' ExtensionLocation + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetDialogLib() As Object +' Return actual Access2Base dialogs library + +Dim oDialogLib As Object + + Set oDialogLib = DialogLibraries + If oDialogLib.hasByName("Access2BaseDev") Then + If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev") + Set _GetDialogLib = DialogLibraries.Access2BaseDev + ElseIf oDialogLib.hasByName("Access2Base") Then + If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") + Set _GetDialogLib = DialogLibraries.Access2Base + Else + Set _GetDialogLib = Nothing + EndIf + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +' Return the LO internal event name +' Corrects the typo on ErrorOccur(r?)ed + + _GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) & Right(psProperty, Len(psProperty) - 3), "errorOccurred", "errorOccured") + +End Function ' _GetEventName V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetEventScriptCode(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psName As String _ + , Optional ByVal pbExtendName As Boolean _ + ) As String +' Extract from the parent of poObject the macro linked to psEvent. +' psName is the name of the object + +Dim i As Integer, vEvents As Variant, sEvent As String, oParent As Object, iIndex As Integer, sName As String + + _GetEventScriptCode = "" + If Not Utils._hasUNOMethod(poObject, "getParent") Then Exit Function + + ' Find form index i.e. find control via getByIndex() + If IsMissing(pbExtendName) Then pbExtendName = False + Set oParent = poObject.getParent() + iIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then Exit Function + + ' Find script event + vEvents = oParent.getScriptEvents(iIndex) ' Returns an array + sEvent = Utils._GetEventName(psEvent) ' Targeted event method + For i = 0 To UBound(vEvents) + If vEvents(i).EventMethod = sEvent Then + _GetEventScriptCode = vEvents(i).ScriptCode + Exit For + End If + Next i + +End Function ' _GetEventScriptCode V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _GetResultSetColumnValue(poResultSet As Object _ + , ByVal piColIndex As Integer _ + , Optional ByVal pbReturnBinary As Boolean _ + ) As Variant +REM Modified from Roberto Benitez's BaseTools +REM get the data for the column specified by ColIndex +REM If pbReturnBinary = False (default) then return length of binary field +REM get type name from metadata + +Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object +Dim bNullable As Boolean, lSize As Long +Const cstMaxTextLength = 65535 +Const cstMaxBinlength = 2 * 65535 + + On Local Error Goto 0 ' Disable error handler + vValue = Null ' Default value if error + If IsMissing(pbReturnBinary) Then pbReturnBinary = False + With com.sun.star.sdbc.DataType + iType = poResultSet.MetaData.getColumnType(piColIndex) + bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + Select Case iType + Case .ARRAY : vValue = poResultSet.getArray(piColIndex) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oValue = poResultSet.getBinaryStream(piColIndex) + If bNullable Then + If Not poResultSet.wasNull() Then + If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset + lSize = cstMaxBinLength + Else + lSize = CLng(oValue.getLength()) + End If + If lSize <= cstMaxBinLength And pbReturnBinary Then + vValue = Array() + oValue.readBytes(vValue, lSize) + Else ' Return length of field, not content + vValue = lSize + End If + End If + End If + oValue.closeInput() + Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(piColIndex) + Case .DATE : vDateTime = poResultSet.getDate(piColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) + Case .DISTINCT, .OBJECT, .OTHER, .STRUCT + vValue = Null + Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(piColIndex) + Case .FLOAT : vValue = poResultSet.getFloat(piColIndex) + Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(piColIndex) + Case .BIGINT : vValue = poResultSet.getLong(piColIndex) + Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(piColIndex) + Case .SQLNULL : vValue = poResultSet.getNull(piColIndex) + Case .OBJECT, .OTHER, .STRUCT : vValue = Null + Case .REF : vValue = poResultSet.getRef(piColIndex) + Case .TINYINT : vValue = poResultSet.getShort(piColIndex) + Case .CHAR, .VARCHAR : vValue = poResultSet.getString(piColIndex) + Case .LONGVARCHAR, .CLOB + Set oValue = poResultSet.getCharacterStream(piColIndex) + If bNullable Then + If Not poResultSet.wasNull() Then + If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset + lSize = cstMaxTextLength + Else + lSize = CLng(oValue.getLength()) + End If + oValue.closeInput() + vValue = poResultSet.getString(piColIndex) + End If + Else + oValue.closeInput() + End If + Case .TIME : vDateTime = poResultSet.getTime(piColIndex) + If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case .TIMESTAMP : vDateTime = poResultSet.getTimeStamp(piColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _ + + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case Else + vValue = poResultSet.getString(piColIndex) 'GIVE STRING A TRY + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + If bNullable Then + If poResultSet.wasNull() Then vValue = Null + End If + End With + + _GetResultSetColumnValue = vValue + +End Function ' GetResultSetColumnValue V 1.5.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _FinalProperty(psShortcut As String) As String +' Return the final property of a shortcut + +Const cstEXCLAMATION = "!" +Const cstDOT = "." + +Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String +Dim sComponents() As String, sSubComponents() As String + _FinalProperty = "" + sComponents = Split(Trim(psShortcut), cstEXCLAMATION) + If UBound(sComponents) = 0 Then Exit Function + sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT) + Select Case UBound(sSubComponents) + Case 1 + _FinalProperty = sSubComponents(1) + Case Else + Exit Function + End Select + +End Function ' FinalProperty + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetProductName(ByVal Optional psFlag As String) as String +'Return OO product ("PRODUCT") and version numbers ("VERSION") +'Derived from Tools library + +Dim oProdNameAccess as Object +Dim sVersion as String +Dim sProdName as String + If IsMissing(psFlag) Then psFlag = "ALL" + oProdNameAccess = _GetRegistryKeyContent("org.openoffice.Setup/Product") + sProdName = oProdNameAccess.getByName("ooName") + sVersion = oProdNameAccess.getByName("ooSetupVersionAboutBox") + Select Case psFlag + Case "ALL" : _GetProductName = sProdName & " " & sVersion + Case "PRODUCT" : _GetProductName = sProdName + Case "VERSION" : _GetProductName = sVersion + End Select +End Function ' GetProductName V1.0.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetRandomFileName(ByVal psName As String) As String +' Return the full name of a random temporary file suffixed by psName + +Dim sRandom As String + sRandom = Right("000000" & Int(999999 * Rnd), 6) + _GetRandomFileName = Utils._getTempDirectoryURL() & "/" & "A2B_TEMP_" & psName & "_" & sRandom + +End Function ' GetRandomFileName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant +'Implement ConfigurationProvider service +'Derived from Tools library + +Dim oConfigProvider as Object +Dim aNodePath(0) as new com.sun.star.beans.PropertyValue + oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") + aNodePath(0).Name = "nodepath" + aNodePath(0).Value = sKeyName + If IsMissing(bForUpdate) Then bForUpdate = False + If bForUpdate Then + _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath()) + Else + _GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath()) + End If +End Function ' GetRegistryKeyContent V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _getTempDirectoryURL() As String +' Return the temporary directory defined in the OO Options (Paths) +Dim sDirectory As String, oSettings As Object, oPathSettings As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + + _getTempDirectoryURL = "" + oPathSettings = createUnoService( "com.sun.star.util.PathSettings" ) + sDirectory = oPathSettings.GetPropertyValue( "Temp" ) + + _getTempDirectoryURL = sDirectory + +Exit_Function: + Exit Function +Error_Function: + TraceError("ERROR", Err, "_getTempDirectoryURL", Erl) + _getTempDirectoryURL = "" + Goto Exit_Function +End Function ' _getTempDirectoryURL V0.8.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _getUNOTypeName(pvObject As Variant) As String +' Return the symbolic name of the pvObject (UNO-object) type +' Code-snippet from XRAY + +Dim oService As Object, vClass as Variant + _getUNOTypeName = "" + On Local Error Resume Next + oService = CreateUnoService("com.sun.star.reflection.CoreReflection") + vClass = oService.getType(pvObject) + If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT Then + _getUNOTypeName = vClass.Name + End If + oService.Dispose() + +End Function ' getUNOTypeName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean +' Return true if pvObject has the (UNO) method psMethod +' Code-snippet found in Bernard Marcelly's XRAY + +Dim vInspect as Variant + _hasUNOMethod = False + If IsNull(pvObject) Then Exit Function + On Local Error Resume Next + vInspect = _A2B_.Introspection.Inspect(pvObject) + _hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL) + +End Function ' hasUNOMethod V0.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean +' Return true if pvObject has the (UNO) property psProperty +' Code-snippet found in Bernard Marcelly's XRAY + +Dim vInspect as Variant + _hasUNOProperty = False + If IsNull(pvObject) Then Exit Function + On Local Error Resume Next + vInspect = _A2B_.Introspection.Inspect(pvObject) + _hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL) + +End Function ' hasUNOProperty V0.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ImplementationName(pvObject As Variant) As String +' Use getImplementationName method or _getUNOTypeName function + +Dim sObjectType As String + On Local Error Resume Next + sObjectType = pvObject.getImplementationName() + If sObjectType = "" Then sObjectType = _getUNOTypeName(pvObject) + + _ImplementationName = sObjectType + +End Function ' ImplementationName + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant +' Return True if pvItem is present in the pvList array (case insensitive comparison) +' Return the value in pvList if pvReturnValue = True + +Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer +Dim iTop As Integer, iBottom As Integer, iFound As Integer + iItemVarType = VarType(pvItem) + If IsMissing(pvReturnValue) Then pvReturnValue = False + If iItemVarType = vbNull Or IsNull(pvList) Then + _InList = False + ElseIf Not IsArray(pvList) Then + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList ) + If Not pvReturnValue Then + _InList = bFound + Else + If bFound Then _InList = pvList Else _InList = False + End If + ElseIf UBound(pvList) < LBound(pvList) Then ' Array not initialized + _InList = False + Else + bFound = False + _InList = False + iListVarType = VarType(pvList(LBound(pvList))) + If iListVarType = iItemVarType _ + Or ( (iListVarType = vbInteger Or iListVarType = vbLong Or iListVarType = vbSingle Or iListVarType = vbDouble _ + Or iListVarType = vbCurrency Or iListVarType = vbBigint Or iListVarType = vbDecimal) _ + And (iItemVarType = vbInteger Or iItemVarType = vbLong Or iItemVarType = vbSingle Or iItemVarType = vbDouble _ + Or iItemVarType = vbCurrency Or iItemVarType = vbBigint Or iItemVarType = vbDecimal) _ + ) Then + If IsMissing(pbBinarySearch) Then pbBinarySearch = False + If Not pbBinarySearch Then ' Linear search + For i = LBound(pvList) To UBound(pvList) + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) ) + If bFound Then + iFound = i + Exit For + End If + Next i + Else ' Binary search => array must be sorted + iTop = UBound(pvList) + iBottom = lBound(pvList) + Do + iFound = (iTop + iBottom) / 2 + If ( iItemVarType = vbString And UCase(pvItem) > UCase(pvList(iFound)) ) Or ( iItemVarType <> vbString And pvItem > pvList(iFound) ) Then + iBottom = iFound + 1 + Else + iTop = iFound - 1 + End If + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) ) + Loop Until ( bFound ) Or ( iBottom > iTop ) + End If + If bFound Then + If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound) + End If + End If + End If + + Exit Function + +End Function ' InList V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String +'Return type of property EVEN WHEN EMPTY ! (Used in date and time controls) + +Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object +' On Local Error Resume Next + _InspectPropertyType = "" + Set oInspect1 = CreateUnoService("com.sun.star.script.Invocation") + Set oInspect2 = oInspect1.createInstanceWithArguments(Array(poObject)).IntroSpection + If Not IsNull(oInspect2) Then + Set oInspect3 = oInspect2.getProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL) + If Not IsNull(oInspect3) Then _InspectPropertyType = oInspect3.Type.Name + End If + Set oInspect1 = Nothing : Set oInspect2 = Nothing : Set oInspect3 = Nothing + +End Function ' InspectPropertyType V1.0.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _IsLeft(psString As String, psLeft As String) As Boolean +' Return True if left part of psString = psLeft + +Dim iLength As Integer + iLength = Len(psLeft) + _IsLeft = False + If Len(psString) >= iLength Then + If Left(psString, iLength) = psLeft Then _IsLeft = True + End If + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _IsBinaryType(ByVal lType As Long) As Boolean + + With com.sun.star.sdbc.DataType + Select Case lType + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + _IsBinaryType = True + Case Else + _IsBinaryType = False + End Select + End With + +End Function ' IsBinaryType V1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean +' Test pvObject: does it exist ? +' is the _Type item = one of the proposed pvTypes ? +' does the pseudo-object refer to an existing object (e.g. does the form really exist in the db) ? + +Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant + + If _ErrorHandler() Then On Local Error Goto Exit_False + + _IsPseudo = False + bIsPseudo = False + vObject = pvObject ' To avoid "Object variable not set" error message + Select Case True + Case IsEmpty(vObject) + Case IsNull(vObject) + Case VarType(vObject) <> vbObject + Case Else + With vObject + Select Case True + Case IsEmpty(._Type) + Case IsNull(._Type) + Case ._Type = "" + Case Else + bIsPseudo = _InList(._Type, pvType) + If Not bIsPseudo Then ' If primary type did not succeed, give the subtype a chance + If ._Type = OBJCONTROL Then bIsPseudo = _InList(._SubType, pvType) + End If + End Select + End With + End Select + + If Not bIsPseudo Then Goto Exit_Function + +Dim oDoc As Object, oForms As Variant +Const cstSeparator = "\;" + + bPseudoExists = False + With vObject + Select Case ._Type + Case OBJFORM + If ._Name <> "" Then ' Check validity of form name + Set oDoc = _A2B_.CurrentDocument() + If oDoc.DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = _InList(._Name, Application._GetAllHierarchicalNames()) + End If + Case OBJDATABASE + If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection) + Case OBJDIALOG + If ._Name <> "" Then ' Check validity of dialog name + bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._Name) ) + End If + Case OBJCOLLECTION + bPseudoExists = True + Case OBJCONTROL + If Not IsNull(.ControlModel) And ._Name <> "" Then ' Check validity of control + Set oForms = .ControlModel.Parent + bPseudoExists = ( oForms.hasByName(._Name) ) + End If + Case OBJSUBFORM + If Not IsNull(.DatabaseForm) And ._Name <> "" Then ' Check validity of subform + If .DatabaseForm.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then + Set oForms = .DatabaseForm.Parent + bPseudoExists = ( oForms.hasByName(._Name) ) + End If + End If + Case OBJOPTIONGROUP + bPseudoExists = ( .Count > 0 ) + Case OBJCOMMANDBAR + bPseudoExists = ( Not IsNull(._Window) ) + Case OBJCOMMANDBARCONTROL + bPseudoExists = ( Not IsNull(._ParentCommandBar) ) + Case OBJEVENT + bPseudoExists = ( Not IsNull(._EventSource) ) + Case OBJPROPERTY + bPseudoExists = ( ._Name <> "" ) + Case OBJTABLEDEF + bPseudoExists = ( ._Name <> "" And Not IsNull(.Table) ) + Case OBJQUERYDEF + bPseudoExists = ( ._Name <> "" And Not IsNull(.Query) ) + Case OBJRECORDSET + bPseudoExists = ( Not IsNull(.RowSet) ) + Case OBJFIELD + bPseudoExists = ( ._Name <> "" And Not IsNull(.Column) ) + Case OBJTEMPVAR + If ._Name <> "" Then ' Check validity of tempvar name + bPseudoExists = ( _A2B_.hasItem(COLLTEMPVARS, ._Name) ) + End If + Case Else + End Select + End With + + _IsPseudo = ( bIsPseudo And bPseudoExists ) + +Exit_Function: + Exit Function +Exit_False: + _IsPseudo = False + Goto Exit_Function +End Function ' IsPseudo V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _IsScalar(ByVal pvArg As Variant, ByVal pvType As Variant, ByVal Optional pvValid As Variant) As Boolean +' Check type of pvArg and value in allowed pvValid list + + _IsScalar = False + + If IsArray(pvType) Then + If Not _InList(VarType(pvArg), pvType) Then Exit Function + ElseIf VarType(pvArg) <> pvType Then + If pvType = vbBoolean And VarType(pvArg) = vbLong Then + If pvArg < -1 And pvArg > 0 Then Exit Function ' Special boolean processing because the Not function returns a Long + Else + Exit Function + End If + End If + If Not IsMissing(pvValid) Then + If Not _InList(pvArg, pvValid) Then Exit Function + End If + + _IsScalar = True + +Exit_Function: + Exit Function +End Function ' IsScalar V0.7.5 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _PCase(ByVal psString As String) As String +' Return the proper case representation of argument + +Dim vSubStrings() As Variant, i As Integer, iLen As Integer + vSubStrings = Split(psString, " ") + For i = 0 To UBound(vSubStrings) + iLen = Len(vSubStrings(i)) + If iLen > 1 Then + vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) & LCase(Right(vSubStrings(i), iLen - 1)) + ElseIf iLen = 1 Then + vSubStrings(i) = UCase(vSubStrings(i)) + End If + Next i + _PCase = Join(vSubStrings, " ") + +End Function ' PCase V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PercentEncode(ByVal psChar As String) As String +' Percent encoding of single psChar character +' https://en.wikipedia.org/wiki/UTF-8 + +Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String + lChar = Asc(psChar) + + Select Case lChar + Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z + _PercentEncode = psChar + Case Asc("-"), Asc("."), Asc("_"), Asc("~") + _PercentEncode = psChar + Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimiters in query strings + _PercentEncode = psChar + Case Asc(" "), Asc("%") + _PercentEncode = "%" & Right("00" & Hex(lChar), 2) + Case 0 To 127 + _PercentEncode = psChar + Case 128 To 2047 + sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2) + sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2) + _PercentEncode = sByte1 & sByte2 + Case 2048 To 65535 + sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2) + sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2) + sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2) + _PercentEncode = sByte1 & sByte2 & sByte3 + Case Else ' Not supported + _PercentEncode = psChar + End Select + + Exit Function + +End Function ' _PercentEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReadFileIntoArray(ByVal psFileName) As Variant +' Loads all lines of a text file into a Variant array +' Any error reduces output to an empty array +' Input file name presumed in URL form + +Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As Integer, iCount2 As Integer +Const cstMaxLines = 16000 ' +/- the limit of array sizes in Basic + On Local Error GoTo Error_Function + vLines = Array() + _ReadFileIntoArray = Array() + If psFileName = "" Then Exit Function + + iFile = FreeFile() + Open psFileName For Input Access Read Shared As #iFile + iCount1 = 0 + Do While Not Eof(iFile) And iCount1 < cstMaxLines + Line Input #iFile, sLine + iCount1 = iCount1 + 1 + Loop + Close #iFile + + ReDim vLines(0 To iCount1 - 1) ' Reading file twice preferred to ReDim Preserve for performance reasons + iFile = FreeFile() + Open psFileName For Input Access Read Shared As #iFile + iCount2 = 0 + Do While Not Eof(iFile) And iCount2 < iCount1 + Line Input #iFile, vLines(iCount2) + iCount2 = iCount2 + 1 + Loop + Close #iFile + +Exit_Function: + _ReadFileIntoArray() = vLines() + Exit Function +Error_Function: + vLines = Array() + Resume Exit_Function +End Function ' _ReadFileIntoArray V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RegexSearch(ByRef psString As String _ + , ByVal psRegex As String _ + , Optional ByRef plStart As Long _ + , Optional ByVal bForward As Boolean _ + ) As String +' Search is not case-sensitive +' Return "" if regex not found, otherwise returns the matching string +' plStart = start position of psString to search (starts at 1) +' In output plStart contains the first position of the matching string +' To search again the same or another pattern => plStart = plStart + Len(matching string) + +Dim oTextSearch As Object +Dim vOptions As Variant 'com.sun.star.util.SearchOptions +Dim lEnd As Long, vResult As Object + + _RegexSearch = "" + Set oTextSearch = _A2B_.TextSearch ' UNO XTextSearch service + vOptions = _A2B_.SearchOptions + vOptions.searchString = psRegex ' Pattern to be searched + oTextSearch.setOptions(vOptions) + If IsMissing(plStart) Then plStart = 1 + If plStart <= 0 Or plStart > Len(psString) Then Exit Function + If IsMissing(bForWard) Then bForward = True + If bForward Then + lEnd = Len(psString) + vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd) + Else + lEnd = 1 + vResult = oTextSearch.searchForward(psString, plStart, lEnd - 1) + End If + With vResult + If .subRegExpressions >= 1 Then + ' http://www.openoffice.org/api/docs/common/ref/com/sun/star/util/SearchResult.html + Select Case bForward + Case True + plStart = .startOffset(0) + 1 + lEnd = .endOffset(0) + 1 + Case False + plStart = .endOffset(0) + 1 + lEnd = .startOffset(0) + End Select + _RegexSearch = Mid(psString, plStart, lEnd - plStart) + Else + plStart = 0 + End If + End With + +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RegisterDialogEventScript(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psListener As String _ + , ByVal psScriptCode As String _ + ) As Boolean +' Register a script event (psEvent) to poObject (Dialog or dialog Control) + +Dim oEvents As Object, sEvent As String, sEventName As String, oEvent As Object + + _RegisterDialogEventScript = False + If Not _hasUNOMethod(poObject, "getEvents") Then Exit Function + +' Remove existing event, if any, then store new script code + Set oEvents = poObject.getEvents() + sEvent = Utils._GetEventName(psEvent) + sEventName = "com.sun.star.awt." & psListener & "::" & sEvent + If oEvents.hasByName(sEventName) Then oEvents.removeByName(sEventName) + Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor") + With oEvent + .ListenerType = psListener + .EventMethod = sEvent + .ScriptType = "Script" ' Better than "Basic" + .ScriptCode = psScriptCode + End With + oEvents.insertByName(sEventName, oEvent) + + _RegisterDialogEventScript = True + +End Function ' _RegisterDialogEventScript V1.8.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RegisterEventScript(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psListener As String _ + , ByVal psScriptCode As String _ + , ByVal psName As String _ + , Optional ByVal pbExtendName As Boolean _ + ) As Boolean +' Register a script event (psEvent) to poObject (Form, SubForm or Control) + +Dim i As Integer, oEvent As Object, sEvent As String, oParent As Object, iIndex As Integer, sName As String + + _RegisterEventScript = False + If Not _hasUNOMethod(poObject, "getParent") Then Exit Function + + ' Find object internal index i.e. how to reach it via getByIndex() + If IsMissing(pbExtendName) Then pbExtendName = False + Set oParent = poObject.getParent() + iIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then + iIndex = i + Exit For + End If + Next i + If iIndex < 0 Then Exit Function + + sEvent = Utils._GetEventName(psEvent) ' Targeted event method + If psScriptCode = "" Then + oParent.revokeScriptEvent(iIndex, psListener, sEvent, "") + Else + Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor") + With oEvent + .ListenerType = psListener + .EventMethod = sEvent + .ScriptType = "Script" ' Better than "Basic" + .ScriptCode = psScriptCode + End With + oParent.registerScriptEvent(iIndex, oEvent) + End If + _RegisterEventScript = True + +End Function ' _RegisterEventScript V1.7.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _ResetCalledSub(ByVal psSub As String) +' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling +' Used to trace routine in/outs and to clarify error messages + If IsEmpty(_A2B_) Then Call Application._RootInit() ' Only when Utils module recompiled + With _A2B_ + If .CalledSub = psSub Then .CalledSub = "" + If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False) + End With +End Sub ' ResetCalledSub + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean +' Execute a given script with pvArgs() array of arguments + + On Local Error Goto Error_Function + _RunScript = False + If IsNull(ThisComponent) Then Goto Exit_Function + +Dim oSCriptProvider As Object, oScript As Object, vResult As Variant + + Set oScriptProvider = ThisComponent.ScriptProvider() + Set oScript = oScriptProvider.getScript(psScript) + If IsMissing(pvArgs()) Then pvArgs() = Array() + vResult = oScript.Invoke(pvArgs(), Array(), Array()) + _RunScript = True + +Exit_Function: + Exit Function +Error_Function: + _RunScript = False + Goto Exit_Function +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Sub _SetCalledSub(ByVal psSub As String) +' Called in top of each public function. +' Used to trace routine in/outs and to clarify error messages + If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session + With _A2B_ + If .CalledSub = "" Then + .CalledSub = psSub + .LastErrorCode = 0 + .LastErrorLevel = "" + .ErrorText = "" + .ErrorLongText = "" + End If + If .MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False) + End With +End Sub ' SetCalledSub + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Surround(ByVal psName As String) As String +' Return [Name] if Name contains spaces +' Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots + +Const cstSquareOpen = "[" +Const cstSquareClose = "]" +Const cstDot = "." +Dim sName As String + + If InStr(psName, ".") > 0 Then + sName = Join(Split(psName, cstDot), cstSquareClose & cstDot & cstSquareOpen) + _Surround = cstSquareOpen & sName & cstSquareClose + ElseIf InStr(psName, " ") > 0 Then + _Surround = cstSquareOpen & psName & cstSquareClose + Else + _Surround = psName + End If + +End Function ' Surround + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Trim(ByVal psString As String) As String +' Remove leading and trailing spaces, remove surrounding square brackets, replace tabs by spaces +Const cstSquareOpen = "[" +Const cstSquareClose = "]" +Dim sTrim As String + + sTrim = Trim(Replace(psString, vbTab, " ")) + _Trim = sTrim + If Len(sTrim) <= 2 Then Exit Function + + If Left(sTrim, 1) = cstSquareOpen Then + If Right(sTrim, 1) = cstSquareClose Then + _Trim = Mid(sTrim, 2, Len(sTrim) - 2) + End If + End If +End Function ' Trim V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _TrimArray(pvArray As Variant) As Variant +' Remove empty strings from strings array + +Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer + vTrim = Null + If Not IsArray(pvArray) Then + If Len(Trim(pvArray)) > 0 Then vTrim = Array(pvArray) Else vTrim = Array() + ElseIf UBound(pvArray) < LBound(pvArray) Then ' Array empty + vTrim = Array() + Else + iCount = 0 + For i = LBound(pvArray) To UBound(pvArray) + If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1 + Next i + If iCount = 0 Then + vTrim() = pvArray() + ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then ' Array empty or all blanks + vTrim() = Array() + Else + ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount) + j = 0 + For i = LBound(pvArray) To UBound(pvArray) + If Len(Trim(pvArray(i))) > 0 Then + vTrim(j) = pvArray(i) + j = j + 1 + End If + Next i + End If + End If + + _TrimArray() = vTrim() + +End Function ' TrimArray V0.9.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _ + , poResultSet As Object _ + , ByVal piColIndex As Integer _ + , ByVal pvValue As Variant _ + ) As Boolean +REM store the pvValue for the column specified by ColIndex +REM get type name from metadata + +Dim iType As Integer, vDateTime As Variant, oValue As Object +Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName As String +Const cstMaxTextLength = 65535 +Const cstMaxBinlength = 2 * 65535 + + On Local Error Goto 0 ' Disable error handler + _UpdateResultSetColumnValue = False + With com.sun.star.sdbc.DataType + iType = poResultSet.MetaData.getColumnType(piColIndex) + iValueType = VarType(pvValue) + sValueTypeName = UCase(poResultSet.MetaData.getColumnTypeName(piColIndex)) + bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + + If bNullable And IsNull(pvValue) Then + poResultSet.updateNull(piColIndex) + Else + Select Case iType + Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF, .SQLNULL, .STRUCT + poResultSet.updateNull(piColIndex) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + poResultSet.updateBytes(piColIndex, pvValue) + Case .BIT, .BOOLEAN : poResultSet.updateBoolean(piColIndex, pvValue) + Case .DATE : vDateTime = CreateUnoStruct("com.sun.star.util.Date") + vDateTime.Year = Year(pvValue) + vDateTime.Month = Month(pvValue) + vDateTime.Day = Day(pvValue) + poResultSet.updateDate(piColIndex, vDateTime) + Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue) + Case .DOUBLE, .REAL : poResultSet.updateDouble(piColIndex, pvValue) + Case .FLOAT : poResultSet.updateFloat(piColIndex, pvValue) + Case .INTEGER, .SMALLINT : poResultSet.updateInt(piColIndex, pvValue) + Case .BIGINT : poResultSet.updateLong(piColIndex, pvValue) + Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue) + Case .TINYINT : poResultSet.updateShort(piColIndex, pvValue) + Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB + If piRDBMS = DBMS_SQLITE And InStr(sValueTypeName, "BINARY") > 0 Then ' Sqlite exception ... ! + poResultSet.updateBytes(piColIndex, pvValue) + Else + poResultSet.updateString(piColIndex, pvValue) + End If + Case .TIME : vDateTime = CreateUnoStruct("com.sun.star.util.Time") + vDateTime.Hours = Hour(pvValue) + vDateTime.Minutes = Minute(pvValue) + vDateTime.Seconds = Second(pvValue) + 'vDateTime.HundredthSeconds = 0 + poResultSet.updateTime(piColIndex, vDateTime) + Case .TIMESTAMP : vDateTime = CreateUnoStruct("com.sun.star.util.DateTime") + vDateTime.Year = Year(pvValue) + vDateTime.Month = Month(pvValue) + vDateTime.Day = Day(pvValue) + vDateTime.Hours = Hour(pvValue) + vDateTime.Minutes = Minute(pvValue) + vDateTime.Seconds = Second(pvValue) + 'vDateTime.HundredthSeconds = 0 + poResultSet.updateTimestamp(piColIndex, vDateTime) + Case Else + If bNullable Then poResultSet.updateNull(piColIndex) + End Select + End If + + End With + + _UpdateResultSetColumnValue = True + +End Function ' UpdateResultSetColumnValue V 1.6.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _URLEncode(ByVal psToEncode As String) As String +' http://www.w3schools.com/tags/ref_urlencode.asp +' http://xkr.us/articles/javascript/encode-compare/ +' http://tools.ietf.org/html/rfc3986 + +Dim sEncoded As String, sChar As String +Dim lCurrentChar As Long, bQuestionMark As Boolean + + sEncoded = "" + bQuestionMark = False + For lCurrentChar = 1 To Len(psToEncode) + sChar = Mid(psToEncode, lCurrentChar, 1) + Select Case sChar + Case " ", "%" + sEncoded = sEncoded & _PercentEncode(sChar) + Case "?" ' Is it the first "?" ? + If bQuestionMark Then ' "?" introduces in a URL the arguments part + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & sChar + bQuestionMark = True + End If + Case "\" + If bQuestionMark Then + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & "/" ' If Windows file naming ... + End If + Case Else + If bQuestionMark Then + sEncoded = sEncoded & _PercentEncode(sChar) + Else + sEncoded = sEncoded & _UTF8Encode(sChar) ' Because IE does not support %encoding in first part of URL + End If + End Select + Next lCurrentChar + + _URLEncode = sEncoded + +End Function ' _URLEncode V1.4.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _UTF8Encode(ByVal psChar As String) As String +' &-encoding of single psChar character (e.g. "é" becomes "&eacute;" or numeric equivalent +' http://www.w3schools.com/charsets/ref_html_utf8.asp + + Select Case psChar + Case """" : _UTF8Encode = "&quot;" + Case "&" : _UTF8Encode = "&amp;" + Case "<" : _UTF8Encode = "&lt;" + Case ">" : _UTF8Encode = "&gt;" + Case "'" : _UTF8Encode = "&apos;" + Case ":", "/", "?", "#", "[", "]", "@" ' Reserved characters + _UTF8Encode = psChar + Case Chr(13) : _UTF8Encode = "" ' Carriage return + Case Chr(10) : _UTF8Encode = "<br>" ' Line Feed + Case < Chr(126) : _UTF8Encode = psChar + Case "€" : _UTF8Encode = "&euro;" + Case Else : _UTF8Encode = "&#" & Asc(psChar) & ";" + End Select + + Exit Function + +End Function ' _UTF8Encode V1.4.0 + + \ No newline at end of file diff --git a/wizards/source/access2base/_License.xba b/wizards/source/access2base/_License.xba new file mode 100644 index 000000000..fa8a5743b --- /dev/null +++ b/wizards/source/access2base/_License.xba @@ -0,0 +1,25 @@ + + + +' Copyright 2012-2017 Jean-Pierre LEDURE + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +' Access2Base is distributed in the hope that it will be useful, +' but WITHOUT ANY WARRANTY; without even the implied warranty of +' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +' Access2Base is free software; you can redistribute it and/or modify it under the terms of either (at your option): +' +' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . +' +' 2) The GNU Lesser General Public License as published by +' the Free Software Foundation, either version 3 of the License, or +' (at your option) any later version. If a copy of the LGPL was not +' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/access2base/acConstants.xba b/wizards/source/access2base/acConstants.xba new file mode 100644 index 000000000..85098c7f4 --- /dev/null +++ b/wizards/source/access2base/acConstants.xba @@ -0,0 +1,395 @@ + + + +REM ======================================================================================================================= +REM === The Access2Base library is a part of the LibreOffice project. === +REM === Full documentation is available on http://www.access2base.com === +REM ======================================================================================================================= + +Option Explicit + +REM Access2Base ----------------------------------------------------- +Global Const Access2Base_Version = "7.1.0" ' Alignment on LibreOffice versions + +REM AcCloseSave +REM ----------------------------------------------------------------- +Global Const acSaveNo = 2 +Global Const acSavePrompt = 0 +Global Const acSaveYes = 1 + +REM AcFormView +REM ----------------------------------------------------------------- +Global Const acDesign = 1 +Global Const acNormal = 0 +Global Const acPreview = 2 + +REM AcFormOpenDataMode +REM ----------------------------------------------------------------- +Global Const acFormAdd = 0 +Global Const acFormEdit = 1 +Global Const acFormPropertySettings = -1 +Global Const acFormReadOnly = 2 + +REM acView +REM ----------------------------------------------------------------- +Global Const acViewDesign = 1 +Global Const acViewNormal = 0 +Global Const acViewPreview = 2 + +REM acOpenDataMode +REM ----------------------------------------------------------------- +Global Const acAdd = 0 +Global Const acEdit = 1 +Global Const acReadOnly = 2 + +REM AcObjectType +REM ----------------------------------------------------------------- +Global Const acDefault = -1 +Global Const acDiagram = 8 +Global Const acForm = 2 +Global Const acQuery = 1 +Global Const acReport = 3 +Global Const acTable = 0 +' Unexisting in MS/Access +Global Const acBasicIDE = 101 +Global Const acDatabaseWindow = 102 +Global Const acDocument = 111 +Global Const acWelcome = 112 +' Subtype if acDocument +Global Const docWriter = "Writer" +Global Const docCalc = "Calc" +Global Const docImpress = "Impress" +Global Const docDraw = "Draw" +Global Const docMath = "Math" + +REM AcWindowMode +REM ----------------------------------------------------------------- +Global Const acDialog = 3 +Global Const acHidden = 1 +Global Const acIcon = 2 +Global Const acWindowNormal = 0 + +REM VarType constants +REM ----------------------------------------------------------------- +Global Const vbEmpty = 0 +Global Const vbNull = 1 +Global Const vbInteger = 2 +Global Const vbLong = 3 +Global Const vbSingle = 4 +Global Const vbDouble = 5 +Global Const vbCurrency = 6 +Global Const vbDate = 7 +Global Const vbString = 8 +Global Const vbObject = 9 +Global Const vbError = 10 +Global Const vbBoolean = 11 +Global Const vbVariant = 12 +Global Const vbByte = 17 +Global Const vbUShort = 18 +Global Const vbULong = 19 +Global Const vbBigint = 35 +Global Const vbDecimal = 37 +Global Const vbArray = 8192 + +REM MsgBox constants +REM ----------------------------------------------------------------- +Global Const vbOKOnly = 0 ' OK button only (default) +Global Const vbOKCancel = 1 ' OK and Cancel buttons +Global Const vbAbortRetryIgnore = 2 ' Abort, Retry, and Ignore buttons +Global Const vbYesNoCancel = 3 ' Yes, No, and Cancel buttons +Global Const vbYesNo = 4 ' Yes and No buttons +Global Const vbRetryCancel = 5 ' Retry and Cancel buttons +Global Const vbCritical = 16 ' Critical message +Global Const vbQuestion = 32 ' Warning query +Global Const vbExclamation = 48 ' Warning message +Global Const vbInformation = 64 ' Information message +Global Const vbDefaultButton1 = 128 ' First button is default (default) (VBA: 0) +Global Const vbDefaultButton2 = 256 ' Second button is default +Global Const vbDefaultButton3 = 512 ' Third button is default +Global Const vbApplicationModal = 0 ' Application modal message box (default) +REM MsgBox Return Values +REM ----------------------------------------------------------------- +Global Const vbOK = 1 ' OK button pressed +Global Const vbCancel = 2 ' Cancel button pressed +Global Const vbAbort = 3 ' Abort button pressed +Global Const vbRetry = 4 ' Retry button pressed +Global Const vbIgnore = 5 ' Ignore button pressed +Global Const vbYes = 6 ' Yes button pressed +Global Const vbNo = 7 ' No button pressed + +REM Dialogs Return Values +REM ------------------------------------------------------------------ +Global Const dlgOK = 1 ' OK button pressed +Global Const dlgCancel = 0 ' Cancel button pressed + +REM Control Types +REM ----------------------------------------------------------------- +Global Const acCheckBox = 5 +Global Const acComboBox = 7 +Global Const acCommandButton = 2 : Global Const acToggleButton = 122 +Global Const acCurrencyField = 18 +Global Const acDateField = 15 +Global Const acFileControl = 12 +Global Const acFixedLine = 24 ' FREE ENTRY (USEFUL IN DIALOGS) +Global Const acFixedText = 10 : Global Const acLabel = 10 +Global Const acFormattedField = 1 ' FREE ENTRY TAKEN TO NOT CONFUSE WITH acTextField +Global Const acGridControl = 11 +Global Const acGroupBox = 8 : Global Const acOptionGroup = 8 +Global Const acHiddenControl = 13 +Global Const acImageButton = 4 +Global Const acImageControl = 14 : Global Const acImage = 14 +Global Const acListBox = 6 +Global Const acNavigationBar = 22 +Global Const acNumericField = 17 +Global Const acPatternField = 19 +Global Const acProgressBar = 23 ' FREE ENTRY (USEFUL IN DIALOGS) +Global Const acRadioButton = 3 : Global Const acOptionButton = 3 +Global Const acScrollBar = 20 +Global Const acSpinButton = 21 +Global Const acSubform = 112 +Global Const acTextField = 9 : Global Const acTextBox = 9 +Global Const acTimeField = 16 + +REM AcRecord +REM ----------------------------------------------------------------- +Global Const acFirst = 2 +Global Const acGoTo = 4 +Global Const acLast = 3 +Global Const acNewRec = 5 +Global Const acNext = 1 +Global Const acPrevious = 0 + +REM FindRecord +REM ----------------------------------------------------------------- +Global Const acAnywhere = 0 +Global Const acEntire = 1 +Global Const acStart = 2 +Global Const acDown = 1 +Global Const acSearchAll = 2 +Global Const acUp = 0 +Global Const acAll = 0 +Global Const acCurrent = -1 + +REM AcDataObjectType +REM ----------------------------------------------------------------- +Global Const acActiveDataObject = -1 +Global Const acDataForm = 2 +Global Const acDataQuery = 1 +Global Const acDataServerView = 7 +Global Const acDataStoredProcedure = 9 +Global Const acDataTable = 0 + +REM AcQuitOption +REM ----------------------------------------------------------------- +Global Const acQuitPrompt = 0 +Global Const acQuitSaveAll = 1 +Global Const acQuitSaveNone = 2 + +REM AcCommand +REM ----------------------------------------------------------------- +Global Const acCmdAboutMicrosoftAccess = 35 +Global Const acCmdAboutOpenOffice = 35 +Global Const acCmdAboutLibreOffice = 35 +Global Const acCmdVisualBasicEditor = 525 +Global Const acCmdBringToFront = 52 +Global Const acCmdClose = 58 +Global Const acCmdToolbarsCustomize = 165 +Global Const acCmdChangeToCommandButton = 501 +Global Const acCmdChangeToCheckBox = 231 +Global Const acCmdChangeToComboBox = 230 +Global Const acCmdChangeToTextBox = 227 +Global Const acCmdChangeToLabel = 228 +Global Const acCmdChangeToImage = 234 +Global Const acCmdChangeToListBox = 229 +Global Const acCmdChangeToOptionButton = 233 +Global Const acCmdCopy = 190 +Global Const acCmdCut = 189 +Global Const acCmdCreateRelationship = 150 +Global Const acCmdDelete = 337 +Global Const acCmdDatabaseProperties = 256 +Global Const acCmdSQLView = 184 +Global Const acCmdRemove = 366 +Global Const acCmdDesignView = 183 +Global Const acCmdFormView = 281 +Global Const acCmdNewObjectForm = 136 +Global Const acCmdNewObjectTable = 134 +Global Const acCmdNewObjectView = 350 +Global Const acCmdOpenDatabase = 25 +Global Const acCmdNewObjectQuery = 135 +Global Const acCmdShowAllRelationships = 149 +Global Const acCmdNewObjectReport = 137 +Global Const acCmdSelectAll = 333 +Global Const acCmdRemoveTable = 84 +Global Const acCmdOpenTable = 221 +Global Const acCmdRename = 143 +Global Const acCmdDeleteRecord = 223 +Global Const acCmdApplyFilterSort = 93 +Global Const acCmdSnapToGrid = 62 +Global Const acCmdViewGrid = 63 +Global Const acCmdInsertHyperlink = 259 +Global Const acCmdMaximumRecords = 508 +Global Const acCmdObjectBrowser = 200 +Global Const acCmdPaste = 191 +Global Const acCmdPasteSpecial = 64 +Global Const acCmdPrint = 340 +Global Const acCmdPrintPreview = 54 +Global Const acCmdSaveRecord = 97 +Global Const acCmdFind = 30 +Global Const acCmdUndo = 292 +Global Const acCmdRefresh = 18 +Global Const acCmdRemoveFilterSort = 144 +Global Const acCmdRunMacro = 31 +Global Const acCmdSave = 20 +Global Const acCmdSaveAs = 21 +Global Const acCmdSelectAllRecords = 109 +Global Const acCmdSendToBack = 53 +Global Const acCmdSortDescending = 164 +Global Const acCmdSortAscending = 163 +Global Const acCmdTabOrder = 41 +Global Const acCmdDatasheetView = 282 +Global Const acCmdZoomSelection = 371 + +REM AcSendObjectType +REM ----------------------------------------------------------------- +Global Const acSendForm = 2 +Global Const acSendNoObject = -1 +Global Const acSendQuery = 1 +Global Const acSendReport = 3 +Global Const acSendTable = 0 + +REM AcOutputObjectType +REM ----------------------------------------------------------------- +Global Const acOutputTable = 0 +Global Const acOutputQuery = 1 +Global Const acOutputForm = 2 +Global Const acOutputArray = -1 + +REM AcEncoding +REM ----------------------------------------------------------------- +Global Const acUTF8Encoding = 76 + +REM AcFormat +REM ----------------------------------------------------------------- +Global Const acFormatPDF = "writer_pdf_Export" +Global Const acFormatODT = "writer8" +Global Const acFormatDOC = "MS Word 97" +Global Const acFormatHTML = "HTML" +Global Const acFormatODS = "calc8" +Global Const acFormatXLS = "MS Excel 97" +Global Const acFormatXLSX = "Calc MS Excel 2007 XML" +Global Const acFormatTXT = "Text - txt - csv (StarCalc)" + +REM AcExportQuality +REM ----------------------------------------------------------------- +Global Const acExportQualityPrint = 0 +Global Const acExportQualityScreen = 1 + +REM AcSysCmdAction +REM ----------------------------------------------------------------- +Global Const acSysCmdAccessDir = 9 +Global Const acSysCmdAccessVer = 7 +Global Const acSysCmdClearHelpTopic = 11 +Global Const acSysCmdClearStatus = 5 +Global Const acSysCmdGetObjectState = 10 +Global Const acSysCmdGetWorkgroupFile = 13 +Global Const acSysCmdIniFile = 8 +Global Const acSysCmdInitMeter = 1 +Global Const acSysCmdProfile = 12 +Global Const acSysCmdRemoveMeter = 3 +Global Const acSysCmdRuntime = 6 +Global Const acSysCmdSetStatus = 4 +Global Const acSysCmdUpdateMeter = 2 + +REM Type property +REM ----------------------------------------------------------------- +Global Const dbBigInt = 16 +Global Const dbBinary = 9 +Global Const dbBoolean = 1 +Global Const dbByte = 2 +Global Const dbChar = 18 +Global Const dbCurrency = 5 +Global Const dbDate = 8 +Global Const dbDecimal = 20 +Global Const dbDouble = 7 +Global Const dbFloat = 21 +Global Const dbGUID = 15 +Global Const dbInteger = 3 +Global Const dbLong = 4 +Global Const dbLongBinary = 11 ' (OLE Object) +Global Const dbMemo= 12 +Global Const dbNumeric = 19 +Global Const dbSingle = 6 +Global Const dbText = 10 +Global Const dbTime = 22 +Global Const dbTimeStamp = 23 +Global Const dbVarBinary = 17 +Global Const dbUndefined = -1 + +REM Attributes property +REM ----------------------------------------------------------------- +Global Const dbAutoIncrField = 16 +Global Const dbDescending = 1 +Global Const dbFixedField = 1 +Global Const dbHyperlinkField = 32768 +Global Const dbSystemField = 8192 +Global Const dbUpdatableField = 32 +Global Const dbVariableField = 2 + +REM OpenRecordset +REM ----------------------------------------------------------------- +Global Const dbOpenForwardOnly = 8 +Global Const dbSQLPassThrough = 64 +Global Const dbReadOnly = 4 + +REM Query types +REM ----------------------------------------------------------------- +Global Const dbQAction = 240 +Global Const dbQAppend = 64 +Global Const dbQDDL = 4 '96 +Global Const dbQDelete = 32 +Global Const dbQMakeTable = 128 '80 +Global Const dbQSelect = 0 +Global Const dbQSetOperation = 8 '128 +Global Const dbQSQLPassThrough = 1 '112 +Global Const dbQUpdate = 16 '48 + +REM Edit mode +REM ----------------------------------------------------------------- +Global Const dbEditNone = 0 +Global Const dbEditInProgress = 1 +Global Const dbEditAdd = 2 + +REM Toolbars +REM ----------------------------------------------------------------- +Global Const msoBarTypeNormal = 0 ' Usual toolbar +Global Const msoBarTypeMenuBar = 1 ' Menu bar +Global Const msoBarTypePopup = 2 ' Shortcut menu +Global Const msoBarTypeStatusBar = 11 ' Status bar +Global Const msoBarTypeFloater = 12 ' Floating window + +Global Const msoControlButton = 1 ' Command button +Global Const msoControlPopup = 10 ' Popup, submenu + +REM New Lines +REM ----------------------------------------------------------------- +Public Function vbCr() As String : vbCr = Chr(13) : End Function +Public Function vbLf() As String : vbLf = Chr(10) : End Function +Public Function vbNewLine() As String +Const cstWindows = 1 + If GetGuiType() = cstWindows Then vbNewLine = vbCR & vbLF Else vbNewLine = vbLF +End Function ' vbNewLine V1.4.0 +Public Function vbTab() As String : vbTab = Chr(9) : End Function + +REM Module types +REM ----------------------------------------------------------------- +Global Const acClassModule = 1 +Global Const acStandardModule = 0 + +REM (Module) procedure types +REM ----------------------------------------------------------------- +Global Const vbext_pk_Get = 1 ' A Property Get procedure +Global Const vbext_pk_Let = 2 ' A Property Let procedure +Global Const vbext_pk_Proc = 0 ' A Sub or Function procedure +Global Const vbext_pk_Set = 3 ' A Property Set procedure + + \ No newline at end of file diff --git a/wizards/source/access2base/access2base.py b/wizards/source/access2base/access2base.py new file mode 100644 index 000000000..ff0a9fbaa --- /dev/null +++ b/wizards/source/access2base/access2base.py @@ -0,0 +1,1473 @@ +# -*- coding: utf-8 -*- + +# Copyright 2012-2020 Jean-Pierre LEDURE + +# ===================================================================================================================== +# === The Access2Base library is a part of the LibreOffice project. === +# === Full documentation is available on http://www.access2base.com === +# ===================================================================================================================== + +# Access2Base is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# Access2Base is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +# 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +# distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +# 2) The GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. If a copy of the LGPL was not +# distributed with this file, see http://www.gnu.org/licenses/ . + +""" +The access2base.py module implements an interface between Python (user) scripts and the Access2Base Basic library. + +Usage: + from access2base import * +Additionally, if Python and LibreOffice are started in separate processes: + If LibreOffice started from console ... (example for Linux) + ./soffice --accept='socket,host=localhost,port=2019;urp;' + then insert next statement + A2BConnect(hostname = 'localhost', port = 2019) + +Specific documentation about Access2Base and Python: + http://www.access2base.com/access2base.html#%5B%5BAccess2Base%20and%20Python%5D%5D +""" + +import uno +XSCRIPTCONTEXT = uno + +from platform import system as _opsys +import datetime, os, sys, traceback + +_LIBRARY = '' # Should be 'Access2Base' or 'Access2BaseDev' +_VERSION = '7.4' # Actual version number +_WRAPPERMODULE = 'Python' # Module name in the Access2Base library containing Python interfaces + +# CallByName types +_vbGet, _vbLet, _vbMethod, _vbSet, _vbUNO = 2, 4, 1, 8, 16 + + +class _Singleton(type): + """ + A Singleton design pattern + Credits: « Python in a Nutshell » by Alex Martelli, O'Reilly + """ + instances = {} + def __call__(cls, *args, **kwargs): + if cls not in cls.instances: + cls.instances[cls] = super(_Singleton, cls).__call__(*args, **kwargs) + return cls.instances[cls] + + +class acConstants(object, metaclass = _Singleton): + """ + VBA constants used in the Access2Base API. + Values derived from MSAccess, except when conflicts + """ + # Python special constants (used in the protocol between Python and Basic) + # ----------------------------------------------------------------- + Empty = '+++EMPTY+++' + Null = '+++NULL+++' + Missing = '+++MISSING+++' + FromIsoFormat = '%Y-%m-%d %H:%M:%S' # To be used with datetime.datetime.strptime() + + # AcCloseSave + # ----------------------------------------------------------------- + acSaveNo = 2 + acSavePrompt = 0 + acSaveYes = 1 + + # AcFormView + # ----------------------------------------------------------------- + acDesign = 1 + acNormal = 0 + acPreview = 2 + + # AcFormOpenDataMode + # ----------------------------------------------------------------- + acFormAdd = 0 + acFormEdit = 1 + acFormPropertySettings = -1 + acFormReadOnly = 2 + + # acView + # ----------------------------------------------------------------- + acViewDesign = 1 + acViewNormal = 0 + acViewPreview = 2 + + # acOpenDataMode + # ----------------------------------------------------------------- + acAdd = 0 + acEdit = 1 + acReadOnly = 2 + + # AcObjectType + # ----------------------------------------------------------------- + acDefault = -1 + acDiagram = 8 + acForm = 2 + acQuery = 1 + acReport = 3 + acTable = 0 + # Unexisting in MS/Access + acBasicIDE = 101 + acDatabaseWindow = 102 + acDocument = 111 + acWelcome = 112 + # Subtype if acDocument + docWriter = "Writer" + docCalc = "Calc" + docImpress = "Impress" + docDraw = "Draw" + docMath = "Math" + + # AcWindowMode + # ----------------------------------------------------------------- + acDialog = 3 + acHidden = 1 + acIcon = 2 + acWindowNormal = 0 + + # VarType constants + # ----------------------------------------------------------------- + vbEmpty = 0 + vbNull = 1 + vbInteger = 2 + vbLong = 3 + vbSingle = 4 + vbDouble = 5 + vbCurrency = 6 + vbDate = 7 + vbString = 8 + vbObject = 9 + vbBoolean = 11 + vbVariant = 12 + vbByte = 17 + vbUShort = 18 + vbULong = 19 + vbBigint = 35 + vbDecimal = 37 + vbArray = 8192 + + # MsgBox constants + # ----------------------------------------------------------------- + vbOKOnly = 0 # OK button only (default) + vbOKCancel = 1 # OK and Cancel buttons + vbAbortRetryIgnore = 2 # Abort, Retry, and Ignore buttons + vbYesNoCancel = 3 # Yes, No, and Cancel buttons + vbYesNo = 4 # Yes and No buttons + vbRetryCancel = 5 # Retry and Cancel buttons + vbCritical = 16 # Critical message + vbQuestion = 32 # Warning query + vbExclamation = 48 # Warning message + vbInformation = 64 # Information message + vbDefaultButton1 = 128 # First button is default (default) (VBA: 0) + vbDefaultButton2 = 256 # Second button is default + vbDefaultButton3 = 512 # Third button is default + vbApplicationModal = 0 # Application modal message box (default) + # MsgBox Return Values + # ----------------------------------------------------------------- + vbOK = 1 # OK button pressed + vbCancel = 2 # Cancel button pressed + vbAbort = 3 # Abort button pressed + vbRetry = 4 # Retry button pressed + vbIgnore = 5 # Ignore button pressed + vbYes = 6 # Yes button pressed + vbNo = 7 # No button pressed + + # Dialogs Return Values + # ------------------------------------------------------------------ + dlgOK = 1 # OK button pressed + dlgCancel = 0 # Cancel button pressed + + # Control Types + # ----------------------------------------------------------------- + acCheckBox = 5 + acComboBox = 7 + acCommandButton = 2 + acToggleButton = 122 + acCurrencyField = 18 + acDateField = 15 + acFileControl = 12 + acFixedLine = 24 # FREE ENTRY (USEFUL IN DIALOGS) + acFixedText = 10 + acLabel = 10 + acFormattedField = 1 # FREE ENTRY TAKEN TO NOT CONFUSE WITH acTextField + acGridControl = 11 + acGroupBox = 8 + acOptionGroup = 8 + acHiddenControl = 13 + acImageButton = 4 + acImageControl = 14 + acImage = 14 + acListBox = 6 + acNavigationBar = 22 + acNumericField = 17 + acPatternField = 19 + acProgressBar = 23 # FREE ENTRY (USEFUL IN DIALOGS) + acRadioButton = 3 + acOptionButton = 3 + acScrollBar = 20 + acSpinButton = 21 + acSubform = 112 + acTextField = 9 + acTextBox = 9 + acTimeField = 16 + + # AcRecord + # ----------------------------------------------------------------- + acFirst = 2 + acGoTo = 4 + acLast = 3 + acNewRec = 5 + acNext = 1 + acPrevious = 0 + + # FindRecord + # ----------------------------------------------------------------- + acAnywhere = 0 + acEntire = 1 + acStart = 2 + acDown = 1 + acSearchAll = 2 + acUp = 0 + acAll = 0 + acCurrent = -1 + + # AcDataObjectType + # ----------------------------------------------------------------- + acActiveDataObject = -1 + acDataForm = 2 + acDataQuery = 1 + acDataServerView = 7 + acDataStoredProcedure = 9 + acDataTable = 0 + + # AcQuitOption + # ----------------------------------------------------------------- + acQuitPrompt = 0 + acQuitSaveAll = 1 + acQuitSaveNone = 2 + + # AcCommand + # ----------------------------------------------------------------- + acCmdAboutMicrosoftAccess = 35 + acCmdAboutOpenOffice = 35 + acCmdAboutLibreOffice = 35 + acCmdVisualBasicEditor = 525 + acCmdBringToFront = 52 + acCmdClose = 58 + acCmdToolbarsCustomize = 165 + acCmdChangeToCommandButton = 501 + acCmdChangeToCheckBox = 231 + acCmdChangeToComboBox = 230 + acCmdChangeToTextBox = 227 + acCmdChangeToLabel = 228 + acCmdChangeToImage = 234 + acCmdChangeToListBox = 229 + acCmdChangeToOptionButton = 233 + acCmdCopy = 190 + acCmdCut = 189 + acCmdCreateRelationship = 150 + acCmdDelete = 337 + acCmdDatabaseProperties = 256 + acCmdSQLView = 184 + acCmdRemove = 366 + acCmdDesignView = 183 + acCmdFormView = 281 + acCmdNewObjectForm = 136 + acCmdNewObjectTable = 134 + acCmdNewObjectView = 350 + acCmdOpenDatabase = 25 + acCmdNewObjectQuery = 135 + acCmdShowAllRelationships = 149 + acCmdNewObjectReport = 137 + acCmdSelectAll = 333 + acCmdRemoveTable = 84 + acCmdOpenTable = 221 + acCmdRename = 143 + acCmdDeleteRecord = 223 + acCmdApplyFilterSort = 93 + acCmdSnapToGrid = 62 + acCmdViewGrid = 63 + acCmdInsertHyperlink = 259 + acCmdMaximumRecords = 508 + acCmdObjectBrowser = 200 + acCmdPaste = 191 + acCmdPasteSpecial = 64 + acCmdPrint = 340 + acCmdPrintPreview = 54 + acCmdSaveRecord = 97 + acCmdFind = 30 + acCmdUndo = 292 + acCmdRefresh = 18 + acCmdRemoveFilterSort = 144 + acCmdRunMacro = 31 + acCmdSave = 20 + acCmdSaveAs = 21 + acCmdSelectAllRecords = 109 + acCmdSendToBack = 53 + acCmdSortDescending = 164 + acCmdSortAscending = 163 + acCmdTabOrder = 41 + acCmdDatasheetView = 282 + acCmdZoomSelection = 371 + + # AcSendObjectType + # ----------------------------------------------------------------- + acSendForm = 2 + acSendNoObject = -1 + acSendQuery = 1 + acSendReport = 3 + acSendTable = 0 + + # AcOutputObjectType + # ----------------------------------------------------------------- + acOutputTable = 0 + acOutputQuery = 1 + acOutputForm = 2 + acOutputArray = -1 + + # AcEncoding + # ----------------------------------------------------------------- + acUTF8Encoding = 76 + + # AcFormat + # ----------------------------------------------------------------- + acFormatPDF = "writer_pdf_Export" + acFormatODT = "writer8" + acFormatDOC = "MS Word 97" + acFormatHTML = "HTML" + acFormatODS = "calc8" + acFormatXLS = "MS Excel 97" + acFormatXLSX = "Calc MS Excel 2007 XML" + acFormatTXT = "Text - txt - csv (StarCalc)" + + # AcExportQuality + # ----------------------------------------------------------------- + acExportQualityPrint = 0 + acExportQualityScreen = 1 + + # AcSysCmdAction + # ----------------------------------------------------------------- + acSysCmdAccessDir = 9 + acSysCmdAccessVer = 7 + acSysCmdClearHelpTopic = 11 + acSysCmdClearStatus = 5 + acSysCmdGetObjectState = 10 + acSysCmdGetWorkgroupFile = 13 + acSysCmdIniFile = 8 + acSysCmdInitMeter = 1 + acSysCmdProfile = 12 + acSysCmdRemoveMeter = 3 + acSysCmdRuntime = 6 + acSysCmdSetStatus = 4 + acSysCmdUpdateMeter = 2 + + # Type property + # ----------------------------------------------------------------- + dbBigInt = 16 + dbBinary = 9 + dbBoolean = 1 + dbByte = 2 + dbChar = 18 + dbCurrency = 5 + dbDate = 8 + dbDecimal = 20 + dbDouble = 7 + dbFloat = 21 + dbGUID = 15 + dbInteger = 3 + dbLong = 4 + dbLongBinary = 11 # (OLE Object) + dbMemo = 12 + dbNumeric = 19 + dbSingle = 6 + dbText = 10 + dbTime = 22 + dbTimeStamp = 23 + dbVarBinary = 17 + dbUndefined = -1 + + # Attributes property + # ----------------------------------------------------------------- + dbAutoIncrField = 16 + dbDescending = 1 + dbFixedField = 1 + dbHyperlinkField = 32768 + dbSystemField = 8192 + dbUpdatableField = 32 + dbVariableField = 2 + + # OpenRecordset + # ----------------------------------------------------------------- + dbOpenForwardOnly = 8 + dbSQLPassThrough = 64 + dbReadOnly = 4 + + # Query types + # ----------------------------------------------------------------- + dbQAction = 240 + dbQAppend = 64 + dbQDDL = 4 # 96 + dbQDelete = 32 + dbQMakeTable = 128 # 80 + dbQSelect = 0 + dbQSetOperation = 8 # 128 + dbQSQLPassThrough = 1 # 112 + dbQUpdate = 16 # 48 + + # Edit mode + # ----------------------------------------------------------------- + dbEditNone = 0 + dbEditInProgress = 1 + dbEditAdd = 2 + + # Toolbars + # ----------------------------------------------------------------- + msoBarTypeNormal = 0 # Usual toolbar + msoBarTypeMenuBar = 1 # Menu bar + msoBarTypePopup = 2 # Shortcut menu + msoBarTypeStatusBar = 11 # Status bar + msoBarTypeFloater = 12 # Floating window + + msoControlButton = 1 # Command button + msoControlPopup = 10 # Popup, submenu + + # New Lines + # ----------------------------------------------------------------- + vbCr = chr(13) + vbLf = chr(10) + + def _NewLine(): + if _opsys == 'Windows': return chr(13) + chr(10) + return chr(10) + + vbNewLine = _NewLine() + vbTab = chr(9) + + # Module types + # ----------------------------------------------------------------- + acClassModule = 1 + acStandardModule = 0 + + # (Module) procedure types + # ----------------------------------------------------------------- + vbext_pk_Get = 1 # A Property Get procedure + vbext_pk_Let = 2 # A Property Let procedure + vbext_pk_Proc = 0 # A Sub or Function procedure + vbext_pk_Set = 3 # A Property Set procedure + + +COMPONENTCONTEXT, DESKTOP, SCRIPTPROVIDER, THISDATABASEDOCUMENT = None, None, None, None + +def _ErrorHandler(type, value, tb): + ''' + Is the function to be set as new sys.excepthook to bypass the standard error handler + Derived from https://stackoverflow.com/questions/31949760/how-to-limit-python-traceback-to-specific-files + Handler removes traces pointing to methods located in access2base.py when error is due to a user programming error + sys.excepthook = _ErrorHandler + NOT APPLIED YET + ''' + + def check_file(name): + return 'access2base.py' not in name + + show = (fs for fs in traceback.extract_tb(tb) if check_file(fs.filename)) + fmt = traceback.format_list(show) + traceback.format_exception_only(type, value) + print(''.join(fmt), end = '', file = sys.stderr) + # Reset to standard handler + sys.excepthook = sys.__excepthook__ + + +def A2BConnect(hostname = '', port = 0): + """ + To be called explicitly by user scripts when Python process runs outside the LibreOffice process. + LibreOffice started as (Linux): + ./soffice --accept='socket,host=localhost,port=xxxx;urp;' + Otherwise called implicitly by the current module without arguments + Initializes COMPONENTCONTEXT, SCRIPTPROVIDER and DESKTOP + :param hostname: probably 'localhost' or '' + :param port: port number or 0 + :return: None + """ + global XSCRIPTCONTEXT, COMPONENTCONTEXT, DESKTOP, SCRIPTPROVIDER + # Determine COMPONENTCONTEXT, via socket or inside LibreOffice + if len(hostname) > 0 and port > 0: # Explicit connection request via socket + # Code derived from Bridge.py by Alain H. Romedenne + local_context = XSCRIPTCONTEXT.getComponentContext() + resolver = local_context.ServiceManager.createInstanceWithContext( + 'com.sun.star.bridge.UnoUrlResolver', local_context) + try: + conn = 'socket,host=%s,port=%d' % (hostname, port) + connection_url = 'uno:%s;urp;StarOffice.ComponentContext' % conn + established_context = resolver.resolve(connection_url) + except Exception: # thrown when LibreOffice specified instance isn't started + raise ConnectionError('Connection to LibreOffice failed (host = ' + hostname + ', port = ' + str(port) + ')') + COMPONENTCONTEXT = established_context + DESKTOP = None + elif len(hostname) == 0 and port == 0: # Usual interactive mode + COMPONENTCONTEXT = XSCRIPTCONTEXT.getComponentContext() + DESKTOP = COMPONENTCONTEXT.ServiceManager.createInstanceWithContext( 'com.sun.star.frame.Desktop', COMPONENTCONTEXT) + else: + raise SystemExit('The invocation of A2BConnect() has invalid arguments') + # Determine SCRIPTPROVIDER + servicemanager = COMPONENTCONTEXT.ServiceManager + masterscript = servicemanager.createInstanceWithContext("com.sun.star.script.provider.MasterScriptProviderFactory", COMPONENTCONTEXT) + SCRIPTPROVIDER = masterscript.createScriptProvider("") + Script = _A2B.xScript('TraceLog', 'Trace') # Don't use invokeMethod() to force reset of error stack + Script.invoke(('===>', 'Python wrapper loaded V.' + _VERSION, False), (), ()) + return None + + +class _A2B(object, metaclass = _Singleton): + """ + Collection of helper functions implementing the protocol between Python and Basic + Read comments in PythonWrapper Basic function + """ + + @classmethod + def BasicObject(cls, objectname): + objs = {'COLLECTION': _Collection + , 'COMMANDBAR': _CommandBar + , 'COMMANDBARCONTROL': _CommandBarControl + , 'CONTROL': _Control + , 'DATABASE': _Database + , 'DIALOG': _Dialog + , 'EVENT': _Event + , 'FIELD': _Field + , 'FORM': _Form + , 'MODULE': _Module + , 'OPTIONGROUP': _OptionGroup + , 'PROPERTY': _Property + , 'QUERYDEF': _QueryDef + , 'RECORDSET': _Recordset + , 'SUBFORM': _SubForm + , 'TABLEDEF': _TableDef + , 'TEMPVAR': _TempVar + } + return objs[objectname] + + @classmethod + def xScript(cls, script, module): + """ + At first call checks the existence of the Access2Base library + Initializes _LIBRARY with the found library name + First and next calls execute the given script in the given module of the _LIBRARY library + The script and module are presumed to exist + :param script: name of script + :param module: name of module + :return: the script object. NB: the execution is done with the invoke() method applied on the returned object + """ + global _LIBRARY + Script = None + def sScript(lib): + return 'vnd.sun.star.script:' + lib + '.' + module + '.' + script + '?language=Basic&location=application' + if _LIBRARY == '': + # Check the availability of the Access2Base library + for lib in ('Access2BaseDev', 'Access2Base'): + try: + if Script == None: + Script = SCRIPTPROVIDER.getScript(sScript(lib)) + _LIBRARY = lib + except Exception: + pass + if Script == None: + raise SystemExit('Access2Base basic library not found') + else: + Script = SCRIPTPROVIDER.getScript(sScript(_LIBRARY)) + return Script + + @classmethod + def A2BErrorCode(cls): + """ + Return the Access2Base error stack as a tuple + 0 => error code + 1 => severity level + 2 => short error message + 3 => long error message + """ + Script = cls.xScript('TraceErrorCode', 'Trace') + return Script.invoke((), (), ())[0] + + @classmethod + def invokeMethod(cls, script, module, *args): + """ + Direct call to a named script/module pair with their arguments + If the arguments do not match their definition at the Basic side, a TypeError is raised + :param script: name of script + :param module: name of module + :param args: list of arguments to be passed to the script + :return: the value returned by the script execution + """ + if COMPONENTCONTEXT == None: A2BConnect() # Connection from inside LibreOffice is done at first API invocation + Script = cls.xScript(script, module) + try: + Returned = Script.invoke((args), (), ())[0] + except Exception: + raise TypeError("Access2Base error: method '" + script + "' in Basic module '" + module + "' call error. Check its arguments.") + else: + if Returned == None: + if cls.VerifyNoError(): return None + return Returned + + @classmethod + def invokeWrapper(cls, action, basic, script, *args): + """ + Call the Basic wrapper to invite it to execute the proposed action on a Basic object + If the arguments do not match their definition at the Basic side, a TypeError is raised + After execution, a check is done if the execution has raised an error within Basic + If yes, a TypeError is raised + :param action: Property Get, Property Let, Property Set, invoke Method or return UNO object + :param basic: the reference of the Basic object, i.e. the index in the array caching the addresses of the objects + conventionally Application = -1 and DoCmd = -2 + :param script: the property or method name + :param args: the arguments of the method, if any + :return: the value returned by the execution of the Basic routine + """ + if COMPONENTCONTEXT == None: A2BConnect() # Connection from inside LibreOffice is done at first API invocation + # Intercept special call to Application.Events() + if basic == Application.basicmodule and script == 'Events': + Script = cls.xScript('PythonEventsWrapper', _WRAPPERMODULE) + Returned = Script.invoke((args[0],), (), ()) + else: + Script = cls.xScript('PythonWrapper', _WRAPPERMODULE) + NoArgs = '+++NOARGS+++' # Conventional notation for properties/methods without arguments + if len(args) == 0: + args = (action,) + (basic,) + (script,) + (NoArgs,) + else: + args = (action,) + (basic,) + (script,) + args + try: + Returned = Script.invoke((args), (), ()) + except Exception: + raise TypeError("Access2Base error: method '" + script + "' call error. Check its arguments.") + + if isinstance(Returned[0], tuple): + # Is returned value a reference to a basic object, a scalar or a UNO object ? + if len(Returned[0]) in (3, 4): + if Returned[0][0] == 0: # scalar + return Returned[0][1] + elif Returned[0][0] == 1: # reference to objects cache + basicobject = cls.BasicObject(Returned[0][2]) + if len(Returned[0]) == 3: + return basicobject(Returned[0][1], Returned[0][2]) + else: + return basicobject(Returned[0][1], Returned[0][2], Returned[0][3]) + elif Returned[0][0] == 2: # Null value + return None + else: # Should not happen + return None + else: # UNO object + return Returned[0] + elif Returned[0] == None: + if cls.VerifyNoError(): return None + else: # Should not happen + return Returned[0] + + @classmethod + def VerifyNoError(cls): + # has Access2Base generated an error ? + errorstack = cls.A2BErrorCode() # 0 = code, 1 = severity, 2 = short text, 3 = long text + if errorstack[1] in ('ERROR', 'FATAL', 'ABORT'): + raise TypeError('Access2Base error: ' + errorstack[3]) + return True + + +class Application(object, metaclass = _Singleton): + """ Collection of methods located in the Application (Basic) module """ + W = _A2B.invokeWrapper + basicmodule = -1 + + @classmethod + def AllDialogs(cls, dialog = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'AllDialogs', dialog) + @classmethod + def AllForms(cls, form = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'AllForms', form) + @classmethod + def AllModules(cls, module = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'AllModules', module) + @classmethod + def CloseConnection(cls): + return cls.W(_vbMethod, cls.basicmodule, 'CloseConnection') + @classmethod + def CommandBars(cls, bar = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'CommandBars', bar) + @classmethod + def CurrentDb(cls): + return cls.W(_vbMethod, cls.basicmodule, 'CurrentDb') + @classmethod + def CurrentUser(cls): + return cls.W(_vbMethod, cls.basicmodule, 'CurrentUser') + @classmethod + def DAvg(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DAvg', expression, domain, criteria) + @classmethod + def DCount(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DCount', expression, domain, criteria) + @classmethod + def DLookup(cls, expression, domain, criteria = '', orderclause = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DLookup', expression, domain, criteria, orderclause) + @classmethod + def DMax(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DMax', expression, domain, criteria) + @classmethod + def DMin(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DMin', expression, domain, criteria) + @classmethod + def DStDev(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DStDev', expression, domain, criteria) + @classmethod + def DStDevP(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DStDevP', expression, domain, criteria) + @classmethod + def DSum(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DSum', expression, domain, criteria) + @classmethod + def DVar(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DVar', expression, domain, criteria) + @classmethod + def DVarP(cls, expression, domain, criteria = ''): + return cls.W(_vbMethod, cls.basicmodule, 'DVarP', expression, domain, criteria) + @classmethod + def Events(cls, event): + return cls.W(_vbMethod, cls.basicmodule, 'Events', event) + @classmethod + def Forms(cls, form = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'Forms', form) + @classmethod + def getObject(cls, shortcut): + return cls.W(_vbMethod, cls.basicmodule, 'getObject', shortcut) + GetObject = getObject + @classmethod + def getValue(cls, shortcut): + return cls.W(_vbMethod, cls.basicmodule, 'getValue', shortcut) + GetValue = getValue + @classmethod + def HtmlEncode(cls, string, length = 0): + return cls.W(_vbMethod, cls.basicmodule, 'HtmlEncode', string, length) + @classmethod + def OpenConnection(cls, thisdatabasedocument = acConstants.Missing): + global THISDATABASEDOCUMENT + if COMPONENTCONTEXT == None: A2BConnect() # Connection from inside LibreOffice is done at first API invocation + if DESKTOP != None: + THISDATABASEDOCUMENT = DESKTOP.getCurrentComponent() + return _A2B.invokeMethod('OpenConnection', 'Application', THISDATABASEDOCUMENT) + @classmethod + def OpenDatabase(cls, connectionstring, username = '', password = '', readonly = False): + return cls.W(_vbMethod, cls.basicmodule, 'OpenDatabase', connectionstring, username + , password, readonly) + @classmethod + def ProductCode(cls): + return cls.W(_vbMethod, cls.basicmodule, 'ProductCode') + @classmethod + def setValue(cls, shortcut, value): + return cls.W(_vbMethod, cls.basicmodule, 'setValue', shortcut, value) + SetValue = setValue + @classmethod + def SysCmd(cls, action, text = '', value = -1): + return cls.W(_vbMethod, cls.basicmodule, 'SysCmd', action, text, value) + @classmethod + def TempVars(cls, var = acConstants.Missing): + return cls.W(_vbMethod, cls.basicmodule, 'TempVars', var) + @classmethod + def Version(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Version') + + +class DoCmd(object, metaclass = _Singleton): + """ Collection of methods located in the DoCmd (Basic) module """ + W = _A2B.invokeWrapper + basicmodule = -2 + + @classmethod + def ApplyFilter(cls, filter = '', sqlwhere = '', controlname = ''): + return cls.W(_vbMethod, cls.basicmodule, 'ApplyFilter', filter, sqlwhere, controlname) + @classmethod + def Close(cls, objecttype, objectname, save = acConstants.acSavePrompt): + return cls.W(_vbMethod, cls.basicmodule, 'Close', objecttype, objectname, save) + @classmethod + def CopyObject(cls, sourcedatabase, newname, sourceobjecttype, sourceobjectname): # 1st argument must be set + return cls.W(_vbMethod, cls.basicmodule, 'CopyObject', sourcedatabase, newname, sourceobjecttype + , sourceobjectname) + @classmethod + def FindNext(cls): + return cls.W(_vbMethod, cls.basicmodule, 'FindNext') + @classmethod + def FindRecord(cls, findwhat, match = acConstants.acEntire, matchcase = False, search = acConstants.acSearchAll + , searchasformatted = False, onlycurrentfield = acConstants.acCurrent, findfirst = True): + return cls.W(_vbMethod, cls.basicmodule, 'FindRecord', findwhat, match, matchcase, search + , searchasformatted, onlycurrentfield, findfirst) + @classmethod + def GetHiddenAttribute(cls, objecttype, objectname = ''): + return cls.W(_vbMethod, cls.basicmodule, 'GetHiddenAttribute', objecttype, objectname) + @classmethod + def GoToControl(cls, controlname): + return cls.W(_vbMethod, cls.basicmodule, 'GoToControl', controlname) + @classmethod + def GoToRecord(cls, objecttype = acConstants.acActiveDataObject, objectname = '', record = acConstants.acNext + , offset = 1): + return cls.W(_vbMethod, cls.basicmodule, 'GoToRecord', objecttype, objectname, record, offset) + @classmethod + def Maximize(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Maximize') + @classmethod + def Minimize(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Minimize') + @classmethod + def MoveSize(cls, left = -1, top = -1, width = -1, height = -1): + return cls.W(_vbMethod, cls.basicmodule, 'MoveSize', left, top, width, height) + @classmethod + def OpenForm(cls, formname, view = acConstants.acNormal, filter = '', wherecondition = '' + , datamode = acConstants.acFormEdit, windowmode = acConstants.acWindowNormal, openargs = ''): + return cls.W(_vbMethod, cls.basicmodule, 'OpenForm', formname, view, filter, wherecondition + , datamode, windowmode, openargs) + @classmethod + def OpenQuery(cls, queryname, view = acConstants.acNormal, datamode = acConstants.acEdit): + return cls.W(_vbMethod, cls.basicmodule, 'OpenQuery', queryname, view, datamode) + @classmethod + def OpenReport(cls, queryname, view = acConstants.acNormal): + return cls.W(_vbMethod, cls.basicmodule, 'OpenReport', queryname, view) + @classmethod + def OpenSQL(cls, sql, option = -1): + return cls.W(_vbMethod, cls.basicmodule, 'OpenSQL', sql, option) + @classmethod + def OpenTable(cls, tablename, view = acConstants.acNormal, datamode = acConstants.acEdit): + return cls.W(_vbMethod, cls.basicmodule, 'OpenTable', tablename, view, datamode) + @classmethod + def OutputTo(cls, objecttype, objectname = '', outputformat = '', outputfile = '', autostart = False, templatefile = '' + , encoding = acConstants.acUTF8Encoding, quality = acConstants.acExportQualityPrint): + if objecttype == acConstants.acOutputForm: encoding = 0 + return cls.W(_vbMethod, cls.basicmodule, 'OutputTo', objecttype, objectname, outputformat + , outputfile, autostart, templatefile, encoding, quality) + @classmethod + def Quit(cls): + return cls.W(_vbMethod, cls.basicmodule, 'Quit') + @classmethod + def RunApp(cls, commandline): + return cls.W(_vbMethod, cls.basicmodule, 'RunApp', commandline) + @classmethod + def RunCommand(cls, command): + return cls.W(_vbMethod, cls.basicmodule, 'RunCommand', command) + @classmethod + def RunSQL(cls, SQL, option = -1): + return cls.W(_vbMethod, cls.basicmodule, 'RunSQL', SQL, option) + @classmethod + def SelectObject(cls, objecttype, objectname = '', indatabasewindow = False): + return cls.W(_vbMethod, cls.basicmodule, 'SelectObject', objecttype, objectname, indatabasewindow) + @classmethod + def SendObject(cls, objecttype = acConstants.acSendNoObject, objectname = '', outputformat = '', to = '', cc = '' + , bcc = '', subject = '', messagetext = '', editmessage = True, templatefile = ''): + return cls.W(_vbMethod, cls.basicmodule, 'SendObject', objecttype, objectname, outputformat, to, cc + , bcc, subject, messagetext, editmessage, templatefile) + @classmethod + def SetHiddenAttribute(cls, objecttype, objectname = '', hidden = True): + return cls.W(_vbMethod, cls.basicmodule, 'SetHiddenAttribute', objecttype, objectname, hidden) + @classmethod + def SetOrderBy(cls, orderby = '', controlname = ''): + return cls.W(_vbMethod, cls.basicmodule, 'SetOrderBy', orderby, controlname) + @classmethod + def ShowAllRecords(cls): + return cls.W(_vbMethod, cls.basicmodule, 'ShowAllRecords') + + +class Basic(object, metaclass = _Singleton): + """ Collection of helper functions having the same behaviour as their Basic counterparts """ + M = _A2B.invokeMethod + + @classmethod + def ConvertFromUrl(cls, url): + return cls.M('PyConvertFromUrl', _WRAPPERMODULE, url) + + @classmethod + def ConvertToUrl(cls, file): + return cls.M('PyConvertToUrl', _WRAPPERMODULE, file) + + @classmethod + def CreateUnoService(cls, servicename): + return cls.M('PyCreateUnoService', _WRAPPERMODULE, servicename) + + @classmethod + def DateAdd(cls, add, count, datearg): + if isinstance(datearg, datetime.datetime): datearg = datearg.isoformat() + dateadd = cls.M('PyDateAdd', _WRAPPERMODULE, add, count, datearg) + return datetime.datetime.strptime(dateadd, acConstants.FromIsoFormat) + + @classmethod + def DateDiff(cls, add, date1, date2, weekstart = 1, yearstart = 1): + if isinstance(date1, datetime.datetime): date1 = date1.isoformat() + if isinstance(date2, datetime.datetime): date2 = date2.isoformat() + return cls.M('PyDateDiff', _WRAPPERMODULE, add, date1, date2, weekstart, yearstart) + + @classmethod + def DatePart(cls, add, datearg, weekstart = 1, yearstart = 1): + if isinstance(datearg, datetime.datetime): datearg = datearg.isoformat() + return cls.M('PyDatePart', _WRAPPERMODULE, add, datearg, weekstart, yearstart) + + @classmethod + def DateValue(cls, datestring): + datevalue = cls.M('PyDateValue', _WRAPPERMODULE, datestring) + return datetime.datetime.strptime(datevalue, acConstants.FromIsoFormat) + + @classmethod + def Format(cls, value, format = None): + if isinstance(value, (datetime.datetime, datetime.date, datetime.time, )): + value = value.isoformat() + return cls.M('PyFormat', _WRAPPERMODULE, value, format) + + @classmethod + def GetGUIType(cls): + return cls.M('PyGetGUIType', _WRAPPERMODULE) + + @staticmethod + def GetPathSeparator(): + return os.sep + + @classmethod + def GetSystemTicks(cls): + return cls.M('PyGetSystemTicks', _WRAPPERMODULE) + + @classmethod + def MsgBox(cls, text, type = None, dialogtitle = None): + return cls.M('PyMsgBox', _WRAPPERMODULE, text, type, dialogtitle) + + class GlobalScope(object, metaclass = _Singleton): + @classmethod + def BasicLibraries(cls): + return Basic.M('PyGlobalScope', _WRAPPERMODULE, 'Basic') + @classmethod + def DialogLibraries(self): + return Basic.M('PyGlobalScope', _WRAPPERMODULE, 'Dialog') + + @classmethod + def InputBox(cls, text, title = None, default = None, xpos = None, ypos = None): + return cls.M('PyInputBox', _WRAPPERMODULE, text, title, default, xpos, ypos) + + @staticmethod + def Now(): + return datetime.datetime.now() + + @staticmethod + def RGB(red, green, blue): + return int('%02x%02x%02x' % (red, green, blue), 16) + + @classmethod + def Timer(cls): + return cls.M('PyTimer', _WRAPPERMODULE) + + @staticmethod + def Xray(myObject): + xrayscript = 'vnd.sun.star.script:XrayTool._Main.Xray?language=Basic&location=application' + xScript = SCRIPTPROVIDER.getScript(xrayscript) + xScript.invoke((myObject,), (), ()) + return + + +class _BasicObject(object): + """ + Parent class of Basic objects + Each subclass is identified by its classProperties: + dictionary with keys = allowed properties, value = True if editable or False + Each instance is identified by its + - reference in the cache managed by Basic + - type ('DATABASE', 'COLLECTION', ...) + - name (form, control, ... name) - may be blank + Properties are got and set following next strategy: + 1. Property names are controlled strictly ('Value' and not 'value') + 2. Getting a property value for the first time is always done via a Basic call + 3. Next occurrences are fetched from the Python dictionary of the instance if the property is read-only, otherwise via a Basic call + 4. Methods output might force the deletion of a property from the dictionary ('MoveNext' changes 'BOF' and 'EOF' properties) + 5. Setting a property value is done via a Basic call, except if self.internal == True + """ + W = _A2B.invokeWrapper + internal_attributes = ('objectreference', 'objecttype', 'name', 'internal') + + def __init__(self, reference = -1, objtype = None, name = ''): + self.objectreference = reference # reference in the cache managed by Basic + self.objecttype = objtype # ('DATABASE', 'COLLECTION', ...) + self.name = name # '' when no name + self.internal = False # True to exceptionally allow assigning a new value to a read-only property + self.localProperties = () + + def __getattr__(self, name): + if name in ('classProperties', 'localProperties'): + pass + elif name in self.classProperties: + # Get Property from Basic + return self.W(_vbGet, self.objectreference, name) + # Usual attributes getter + return super(_BasicObject, self).__getattribute__(name) + + def __setattr__(self, name, value): + if name in ('classProperties', 'localProperties'): + pass + elif name in self.classProperties: + if self.internal: # internal = True forces property setting even if property is read-only + pass + elif self.classProperties[name] == True: # True == Editable + self.W(_vbLet, self.objectreference, name, value) + else: + raise AttributeError("type object '" + self.objecttype + "' has no editable attribute '" + name + "'") + elif name[0:2] == '__' or name in self.internal_attributes or name in self.localProperties: + pass + else: + raise AttributeError("type object '" + self.objecttype + "' has no attribute '" + name + "'") + object.__setattr__(self, name, value) + return + + def __repr__(self): + repr = "Basic object (type='" + self.objecttype + "', index=" + str(self.objectreference) + if len(self.name) > 0: repr += ", name='" + self.name + "'" + return repr + ")" + + def _Reset(self, propertyname, basicreturn = None): + """ force new value or erase properties from dictionary (done to optimize calls to Basic scripts) """ + if propertyname in ('BOF', 'EOF'): + # After a Move method invocation on a Recordset object, BOF or EOF likely to be got soon + if isinstance(basicreturn, int): + self.internal = True + # f.i. basicreturn = 0b10 means: BOF = True, EOF = False + self.BOF = basicreturn in (2, 3, -2, -3) + self.EOF = basicreturn in (1, 3, -1, -3) + self.internal = False + return ( basicreturn >= 0 ) + else: + # Suppress possibly invalid property values: e.g. RecordCount after Delete applied on Recordset object + if property in self.__dict__: + del(self.propertyname) + return basicreturn + + @property + def Name(self): return self.name + @property + def ObjectType(self): return self.objecttype + + def Dispose(self): + return self.W(_vbMethod, self.objectreference, 'Dispose') + def getProperty(self, propertyname, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'getProperty', propertyname, index) + GetProperty = getProperty + def hasProperty(self, propertyname): + return propertyname in tuple(self.classProperties.keys()) + HasProperty = hasProperty + def Properties(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Properties', index) + def setProperty(self, propertyname, value, index = acConstants.Missing): + if self.hasProperty(propertyname): + if self.W(_vbMethod, self.objectreference, 'setProperty', propertyname, value, index): + return self.__setattr__(propertyname, value) + raise AttributeError("type object '" + self.objecttype + "' has no editable attribute '" + propertyname + "'") + SetProperty = setProperty + + +class _Collection(_BasicObject): + """ Collection object built as a Python iterator """ + classProperties = dict(Count = False) + def __init__(self, reference = -1, objtype = None): + super().__init__(reference, objtype) + self.localProperties = ('count', 'index') + self.count = self.Count + self.index = 0 + def __iter__(self): + self.index = 0 + return self + def __next__(self): + if self.index >= self.count: + raise StopIteration + next = self.Item(self.index) + self.index = self.index + 1 + return next + def __len__(self): + return self.count + + def Add(self, table, value = acConstants.Missing): + if isinstance(table, _BasicObject): # Add method applied to a TABLEDEFS collection + return self.W(_vbMethod, self.objectreference, 'Add', table.objectreference) + else: # Add method applied to a TEMPVARS collection + add = self.W(_vbMethod, self.objectreference, 'Add', table, value) + self.count = self.Count + return add + def Delete(self, name): + return self.W(_vbMethod, self.objectreference, 'Delete', name) + def Item(self, index): + return self.W(_vbMethod, self.objectreference, 'Item', index) + def Remove(self, tempvarname): + remove = self.W(_vbMethod, self.objectreference, 'Remove', tempvarname) + self.count = self.Count + return remove + def RemoveAll(self): + remove = self.W(_vbMethod, self.objectreference, 'RemoveAll') + self.count = self.Count + return remove + + +class _CommandBar(_BasicObject): + classProperties = dict(BuiltIn = False, Parent = False, Visible = True) + + def CommandBarControls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'CommandBarControls', index) + def Reset(self): + return self.W(_vbMethod, self.objectreference, 'Reset') + + +class _CommandBarControl(_BasicObject): + classProperties = dict(BeginGroup = False, BuiltIn = False, Caption = True, Index = False, OnAction = True + , Parent = False, TooltipText = True, Type = False, Visible = True) + + def Execute(self): + return self.W(_vbMethod, self.objectreference, 'Execute') + + +class _Control(_BasicObject): + classProperties = dict(BackColor = True, BorderColor = True, BorderStyle = True, Cancel = True, Caption = True + , ControlSource = False, ControlTipText = True, ControlType = False, Default = True + , DefaultValue = True, Enabled = True, FontBold = True, FontItalic = True, FontName = True + , FontSize = True, FontUnderline = True, FontWeight = True, ForeColor = True, Form = False + , Format = True, ItemData = False, ListCount = False, ListIndex = True, Locked = True, MultiSelect = True + , OnActionPerformed = True, OnAdjustmentValueChanged = True, OnApproveAction = True + , OnApproveReset = True, OnApproveUpdate = True, OnChanged = True, OnErrorOccurred = True + , OnFocusGained = True, OnFocusLost = True, OnItemStateChanged = True, OnKeyPressed = True + , OnKeyReleased = True, OnMouseDragged = True, OnMouseEntered = True, OnMouseExited = True + , OnMouseMoved = True, OnMousePressed = True, OnMouseReleased = True, OnResetted = True, OnTextChanged = True + , OnUpdated = True, OptionValue = False, Page = False, Parent = False, Picture = True, Required = True + , RowSource = True, RowSourceType = True, Selected = True, SelLength = True, SelStart = True, SelText = True + , SubType = False, TabIndex = True, TabStop = True, Tag = True, Text = False, TextAlign = True + , TripleState = True, Value = True, Visible = True + ) + + @property + def BoundField(self): return self.W(_vbUNO, self.objectreference, 'BoundField') + @property + def ControlModel(self): return self.W(_vbUNO, self.objectreference, 'ControlModel') + @property + def ControlView(self): return self.W(_vbUNO, self.objectreference, 'ControlView') + @property + def LabelControl(self): return self.W(_vbUNO, self.objectreference, 'LabelControl') + + def AddItem(self, value, index = -1): + basicreturn = self.W(_vbMethod, self.objectreference, 'AddItem', value, index) + self._Reset('ItemData') + self._Reset('ListCount') + return basicreturn + def Controls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Controls', index) + # Overrides method in parent class: list of properties is strongly control type dependent + def hasProperty(self, propertyname): + return self.W(_vbMethod, self.objectreference, 'hasProperty', propertyname) + HasProperty = hasProperty + def RemoveItem(self, index): + basicreturn = self.W(_vbMethod, self.objectreference, 'RemoveItem', index) + self._Reset('ItemData') + self._Reset('ListCount') + return basicreturn + def Requery(self): + return self.W(_vbMethod, self.objectreference, 'Requery') + def SetSelected(self, value, index): + return self.W(_vbMethod, self.objectreference, 'SetSelected', value, index) + def SetFocus(self): + return self.W(_vbMethod, self.objectreference, 'SetFocus') + + +class _Database(_BasicObject): + classProperties = dict(Connect = False, OnCreate = True + , OnFocus = True, OnLoad = True, OnLoadFinished = True, OnModifyChanged = True, OnNew = True + , OnPrepareUnload = True, OnPrepareViewClosing = True, OnSave = True, OnSaveAs = True + , OnSaveAsDone = True, OnSaveAsFailed = True, OnSaveDone = True, OnSaveFailed = True + , OnSubComponentClosed = True, OnSubComponentOpened = True, OnTitleChanged = True, OnUnfocus = True + , OnUnload = True, OnViewClosed = True, OnViewCreated = True, Version = False + ) + + @property + def Connection(self): return self.W(_vbUNO, self.objectreference, 'Connection') + @property + def Document(self): return self.W(_vbUNO, self.objectreference, 'Document') + @property + def MetaData(self): return self.W(_vbUNO, self.objectreference, 'MetaData') + + def Close(self): + return self.W(_vbMethod, self.objectreference, 'Close') + def CloseAllRecordsets(self): + return self.W(_vbMethod, self.objectreference, 'CloseAllRecordsets') + def CreateQueryDef(self, name, sqltext, option = -1): + return self.W(_vbMethod, self.objectreference, 'CreateQueryDef', name, sqltext, option) + def CreateTableDef(self, name): + return self.W(_vbMethod, self.objectreference, 'CreateTableDef', name) + def DAvg(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DAvg', expression, domain, criteria) + def DCount(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DCount', expression, domain, criteria) + def DLookup(self, expression, domain, criteria = '', orderclause = ''): + return self.W(_vbMethod, self.objectreference, 'DLookup', expression, domain, criteria, orderclause) + def DMax(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DMax', expression, domain, criteria) + def DMin(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DMin', expression, domain, criteria) + def DStDev(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DStDev', expression, domain, criteria) + def DStDevP(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DStDevP', expression, domain, criteria) + def DVar(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DVar', expression, domain, criteria) + def DVarP(self, expression, domain, criteria = ''): + return self.W(_vbMethod, self.objectreference, 'DVarP', expression, domain, criteria) + def OpenRecordset(self, source, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', source, type, option, lockedit) + def OpenSQL(self, SQL, option = -1): + return self.W(_vbMethod, self.objectreference, 'OpenSQL', SQL, option) + def OutputTo(self, objecttype, objectname = '', outputformat = '', outputfile = '', autostart = False, templatefile = '' + , encoding = acConstants.acUTF8Encoding, quality = acConstants.acExportQualityPrint): + if objecttype == acConstants.acOutputForm: encoding = 0 + return self.W(_vbMethod, self.objectreference, 'OutputTo', objecttype, objectname, outputformat, outputfile + , autostart, templatefile, encoding, quality) + def QueryDefs(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'QueryDefs', index) + def Recordsets(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Recordsets', index) + def RunSQL(self, SQL, option = -1): + return self.W(_vbMethod, self.objectreference, 'RunSQL', SQL, option) + def TableDefs(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'TableDefs', index) + + +class _Dialog(_BasicObject): + classProperties = dict(Caption = True, Height = True, IsLoaded = False, OnFocusGained = True + , OnFocusLost = True, OnKeyPressed = True, OnKeyReleased = True, OnMouseDragged = True + , OnMouseEntered = True, OnMouseExited = True, OnMouseMoved = True, OnMousePressed = True + , OnMouseReleased = True, Page = True, Parent = False, Visible = True, Width = True + ) + + @property + def UnoDialog(self): return self.W(_vbUNO, self.objectreference, 'UnoDialog') + + def EndExecute(self, returnvalue): + return self.W(_vbMethod, self.objectreference, 'EndExecute', returnvalue) + def Execute(self): + return self.W(_vbMethod, self.objectreference, 'Execute') + def Move(self, left = -1, top = -1, width = -1, height = -1): + return self.W(_vbMethod, self.objectreference, 'Move', left, top, width, height) + def OptionGroup(self, groupname): + return self.W(_vbMethod, self.objectreference, 'OptionGroup', groupname) + def Start(self): + return self.W(_vbMethod, self.objectreference, 'Start') + def Terminate(self): + return self.W(_vbMethod, self.objectreference, 'Terminate') + +class _Event(_BasicObject): + classProperties = dict(ButtonLeft = False, ButtonMiddle = False, ButtonRight = False, ClickCount = False + , ContextShortcut = False, EventName = False, EventType = False, FocusChangeTemporary = False + , KeyAlt = False, KeyChar = False, KeyCode = False, KeyCtrl = False, KeyFunction = False, KeyShift = False + , Recommendation = False, RowChangeAction = False, Source = False, SubComponentName = False + , SubComponentType = False, XPos = False, YPos = False + ) + + +class _Field(_BasicObject): + classProperties = dict(DataType = False, DataUpdatable = False, DbType = False, DefaultValue = True + , Description = True, FieldSize = False, Size = False, Source = False + , SourceField = False, SourceTable = False, TypeName = False, Value = True + ) + + @property + def Column(self): return self.W(_vbUNO, self.objectreference, 'Column') + + def AppendChunk(self, value): + return self.W(_vbMethod, self.objectreference, 'AppendChunk', value) + def GetChunk(self, offset, numbytes): + return self.W(_vbMethod, self.objectreference, 'GetChunk', offset, numbytes) + def ReadAllBytes(self, file): + return self.W(_vbMethod, self.objectreference, 'ReadAllBytes', file) + def ReadAllText(self, file): + return self.W(_vbMethod, self.objectreference, 'ReadAllText', file) + def WriteAllBytes(self, file): + return self.W(_vbMethod, self.objectreference, 'WriteAllBytes', file) + def WriteAllText(self, file): + return self.W(_vbMethod, self.objectreference, 'WriteAllText', file) + + +class _Form(_BasicObject): + classProperties = dict(AllowAdditions = True, AllowDeletions = True, AllowEdits = True, Bookmark = True + , Caption = True, CurrentRecord = True, Filter = True, FilterOn = True, Height = True + , IsLoaded = False, OnApproveCursorMove = True, OnApproveParameter = True, OnApproveReset = True + , OnApproveRowChange = True, OnApproveSubmit = True, OnConfirmDelete = True, OnCursorMoved = True + , OnErrorOccurred = True, OnLoaded = True, OnReloaded = True, OnReloading = True, OnResetted = True + , OnRowChanged = True, OnUnloaded = True, OnUnloading = True, OpenArgs = False, OrderBy = True + , OrderByOn = True, Parent = False, Recordset = False, RecordSource = True, Visible = True + , Width = True + ) + + @property + def Component(self): return self.W(_vbUNO, self.objectreference, 'Component') + @property + def ContainerWindow(self): return self.W(_vbUNO, self.objectreference, 'ContainerWindow') + @property + def DatabaseForm(self): return self.W(_vbUNO, self.objectreference, 'DatabaseForm') + + def Close(self): + return self.W(_vbMethod, self.objectreference, 'Close') + def Controls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Controls', index) + def Move(self, left = -1, top = -1, width = -1, height = -1): + return self.W(_vbMethod, self.objectreference, 'Move', left, top, width, height) + def OptionGroup(self, groupname): + return self.W(_vbMethod, self.objectreference, 'OptionGroup', groupname) + def Refresh(self): + return self.W(_vbMethod, self.objectreference, 'Refresh') + def Requery(self): + return self.W(_vbMethod, self.objectreference, 'Requery') + def SetFocus(self): + return self.W(_vbMethod, self.objectreference, 'SetFocus') + + +class _Module(_BasicObject): + classProperties = dict(CountOfDeclarationLines = False, CountOfLines = False, Type = False) + + def __init__(self, reference = -1, objtype = None, name = ''): + super().__init__(reference, objtype, name) + self.localProperties = ('startline', 'startcolumn', 'endline', 'endcolumn', 'prockind') + + def Find(self, target, startline, startcolumn, endline, endcolumn, wholeword = False + , matchcase = False, patternsearch = False): + Returned = self.W(_vbMethod, self.objectreference, 'Find', target, startline, startcolumn, endline + , endcolumn, wholeword, matchcase, patternsearch) + if isinstance(Returned, tuple): + if Returned[0] == True and len(Returned) == 5: + self.startline = Returned[1] + self.startcolumn = Returned[2] + self.endline = Returned[3] + self.endcolumn = Returned[4] + return Returned[0] + return Returned + def Lines(self, line, numlines): + return self.W(_vbMethod, self.objectreference, 'Lines', line, numlines) + def ProcBodyLine(self, procname, prockind): + return self.W(_vbMethod, self.objectreference, 'ProcBodyLine', procname, prockind) + def ProcCountLines(self, procname, prockind): + return self.W(_vbMethod, self.objectreference, 'ProcCountLines', procname, prockind) + def ProcOfLine(self, line, prockind): + Returned = self.W(_vbMethod, self.objectreference, 'ProcOfLine', line, prockind) + if isinstance(Returned, tuple): + if len(Returned) == 2: + self.prockind = Returned[1] + return Returned[0] + return Returned + def ProcStartLine(self, procname, prockind): + return self.W(_vbMethod, self.objectreference, 'ProcStartLine', procname, prockind) + + +class _OptionGroup(_BasicObject): + classProperties = dict(Count = False, Value = True) + + def Controls(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Controls', index) + + +class _Property(_BasicObject): + classProperties = dict(Value = True) + + +class _QueryDef(_BasicObject): + classProperties = dict(SQL = True, Type = False) + + @property + def Query(self): return self.W(_vbUNO, self.objectreference, 'Query') + + def Execute(self, options = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Execute', options) + def Fields(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Fields', index) + def OpenRecordset(self, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', type, option, lockedit) + + +class _Recordset(_BasicObject): + classProperties = dict(AbsolutePosition = True, BOF = False, Bookmark = True, Bookmarkable = False + , EditMode = False, EOF = False, Filter = True, RecordCount = False + ) + + @property + def RowSet(self): return self.W(_vbUNO, self.objectreference, 'RowSet') + + def AddNew(self): + return self.W(_vbMethod, self.objectreference, 'AddNew') + def CancelUpdate(self): + return self.W(_vbMethod, self.objectreference, 'CancelUpdate') + def Clone(self): + return self.W(_vbMethod, self.objectreference, 'Clone') + def Close(self): + return self.W(_vbMethod, self.objectreference, 'Close') + def Delete(self): + return self._Reset('RecordCount',self.W(_vbMethod, self.objectreference, 'Delete')) + def Edit(self): + return self.W(_vbMethod, self.objectreference, 'Edit') + def Fields(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Fields', index) + def GetRows(self, numrows): + return self.W(_vbMethod, self.objectreference, 'GetRows', numrows) + def Move(self, rows, startbookmark = acConstants.Missing): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'Move', rows, startbookmark)) + def MoveFirst(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MoveFirst')) + def MoveLast(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MoveLast')) + def MoveNext(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MoveNext')) + def MovePrevious(self): + return self._Reset('BOF', self.W(_vbMethod, self.objectreference, 'MovePrevious')) + def OpenRecordset(self, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', type, option, lockedit) + def Update(self): + return self._Reset('RecordCount',self.W(_vbMethod, self.objectreference, 'Update')) + + +class _SubForm(_Form): + classProperties = dict(AllowAdditions = True, AllowDeletions = True, AllowEdits = True, CurrentRecord = True + , Filter = True, FilterOn = True, LinkChildFields = False, LinkMasterFields = False + , OnApproveCursorMove = True, OnApproveParameter = True, OnApproveReset = True + , OnApproveRowChange = True, OnApproveSubmit = True, OnConfirmDelete = True, OnCursorMoved = True + , OnErrorOccurred = True, OnLoaded = True, OnReloaded = True, OnReloading = True, OnResetted = True + , OnRowChanged = True, OnUnloaded = True, OnUnloading = True, OrderBy = True + , OrderByOn = True, Parent = False, Recordset = False, RecordSource = True, Visible = True + ) + + def SetFocus(self): + raise AttributeError("type object 'SubForm' has no method 'SetFocus'") + + +class _TableDef(_BasicObject): + classProperties = dict() + + @property + def Table(self): return self.W(_vbUNO, self.objectreference, 'Table') + + def CreateField(self, name, type, size = 0, attributes = 0): + return self.W(_vbMethod, self.objectreference, 'CreateField', name, type, size, attributes) + def Fields(self, index = acConstants.Missing): + return self.W(_vbMethod, self.objectreference, 'Fields', index) + def OpenRecordset(self, type = -1, option = -1, lockedit = -1): + return self.W(_vbMethod, self.objectreference, 'OpenRecordset', type, option, lockedit) + + +class _TempVar(_BasicObject): + classProperties = dict(Value = True) + +""" +Set of directly callable error handling methods +""" +def DebugPrint(*args): + dargs = () + for arg in args: + if isinstance(arg, _BasicObject): + arg = ('[' + arg.objecttype + '] ' + arg.name).rstrip() + dargs = dargs + (arg,) + return _A2B.invokeMethod('DebugPrint', _WRAPPERMODULE, *dargs) +def TraceConsole(): return _A2B.invokeMethod('TraceConsole', 'Trace') +def TraceError(tracelevel, errorcode, errorprocedure, errorline): + return _A2B.invokeMethod('TraceError', 'Trace', tracelevel, errorcode, errorprocedure, errorline) +def TraceLevel(newtracelevel = 'ERROR'): return _A2B.invokeMethod('TraceLevel', 'Trace', newtracelevel) +def TraceLog(tracelevel, text, messagebox = True): + return _A2B.invokeMethod('TraceLog', 'Trace', tracelevel, text, messagebox) + diff --git a/wizards/source/access2base/dialog.xlb b/wizards/source/access2base/dialog.xlb new file mode 100644 index 000000000..dc06162b7 --- /dev/null +++ b/wizards/source/access2base/dialog.xlb @@ -0,0 +1,6 @@ + + + + + + diff --git a/wizards/source/access2base/dlgFormat.xdl b/wizards/source/access2base/dlgFormat.xdl new file mode 100644 index 000000000..4b93fd720 --- /dev/null +++ b/wizards/source/access2base/dlgFormat.xdl @@ -0,0 +1,19 @@ + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/access2base/dlgTrace.xdl b/wizards/source/access2base/dlgTrace.xdl new file mode 100644 index 000000000..08324e47c --- /dev/null +++ b/wizards/source/access2base/dlgTrace.xdl @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/access2base/script.xlb b/wizards/source/access2base/script.xlb new file mode 100644 index 000000000..478a061e8 --- /dev/null +++ b/wizards/source/access2base/script.xlb @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/config/dialog.xlc b/wizards/source/config/dialog.xlc new file mode 100644 index 000000000..34064e83e --- /dev/null +++ b/wizards/source/config/dialog.xlc @@ -0,0 +1,5 @@ + + + + + diff --git a/wizards/source/config/script.xlc b/wizards/source/config/script.xlc new file mode 100644 index 000000000..34064e83e --- /dev/null +++ b/wizards/source/config/script.xlc @@ -0,0 +1,5 @@ + + + + + diff --git a/wizards/source/configshare/dialog.xlc b/wizards/source/configshare/dialog.xlc new file mode 100644 index 000000000..2849d7a9b --- /dev/null +++ b/wizards/source/configshare/dialog.xlc @@ -0,0 +1,19 @@ + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/configshare/script.xlc b/wizards/source/configshare/script.xlc new file mode 100644 index 000000000..ff05ff37b --- /dev/null +++ b/wizards/source/configshare/script.xlc @@ -0,0 +1,19 @@ + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/depot/CommonLang.xba b/wizards/source/depot/CommonLang.xba new file mode 100644 index 000000000..ec2f62733 --- /dev/null +++ b/wizards/source/depot/CommonLang.xba @@ -0,0 +1,368 @@ + + + +REM ***** BASIC ***** + + +' Column A has the index 1 +Public Const SBCOLUMNNAME1 = 3 ' Stock names, sheet 1 +Public Const SBCOLUMNID1 = 4 ' Stock ID, sheet 1 +Public Const SBCOLUMNQUANTITY1 = 5 ' Stock quantity sheet 1 +Public Const SBCOLUMNRATE1 = 7 ' Price for stocks, sheet 1 +Public Const SBCOLUMNNAME2 = 3 ' Stock names, sheet 2 +Public Const SBCOLUMNDATE2 = 4 ' Transaction dates, sheet 2 +Public Const SBCOLUMNQUANTITY2 = 5 ' Transaction quantity, sheet 2 +Public Const SBCOLUMNRATE2 = 6 ' Price for stocks, sheet 2 +Public Const SBCOLUMNPROVPERCENT2 = 7 ' Provision in %, sheet 2 +Public Const SBCOLUMNPROVMIN2 = 8 ' Minimum provision, sheet 2 +Public Const SBCOLUMNPROVFIX2 = 9 ' Fixed provision, sheet 2 +Public Const SBCOLUMNPROCEEDS2 = 12 ' Profit, sheet 2 +Public Const SBCOLUMNQTYSOLD2 = 14 ' Quantity sold, sheet 2 +Public Const SBCOLUMNQTYREST2 = 15 ' Quantity not sold yet, sheet 2 +Public Const SBCOLUMNPRCREST2 = 16 ' Proportional price for quantity not sold yet, sheet 2 +Public Const SBCOLUMNREALPROC2 = 17 ' Realized proceeds, sheet 2 +Public Const SBCOLUMNDIVIDEND2 = 18 ' Dividend paid, sheet 2 +Public Const SBCOLUMNREALPROFIT2 = 19 ' Realized profit, sheet 2 +Public Const SBROWFIRSTTRANSACT2 = 8 ' First data row, sheet 2 +Public Const SBROWHEADER1 = 6 ' Headline, sheet 1 +Public Const SBMSGOK = 0 +Public Const SBMSGYESNO = 4 +Public Const SBMSGSTOP = 16 +Public Const SBMSGQUESTION = 32 +Public Const SBMSGDEFAULTBTN2 = 256 +Public Const SBHASID = 1 ' 0 = no ID, 1 = stocks have an ID +Public Const SBDIALOGSELL = 1 ' Step for main dialog +Public Const SBDIALOGBUY = 2 ' Step for main dialog +Public Const SBBINARY = 0 +Public TransactMode as Integer +Public Const LIFO = -1 +Public Const FIFO = 1 + +Public Const HANDLEDIVIDEND = 1 +Public Const HANDLESPLIT = 2 + +Global oDocument as Object +Global oDocFormats() as Object +Global oController as Object +Global oFirstSheet as Object +Global oBankSheet as Object +Global oMovementSheet as Object +Global sDocLanguage as String +Global sDocCountry as String +Global oSheets as Object +Global oDocLocale as New com.sun.star.lang.Locale +Global bEnableMarket as Boolean +Global bEnableInternet as Boolean +Global oMarketModel as Object +Global oInternetModel as Object + +Global sCurCurrency$, sCurExtension$, sCurChartSource$, sCurStockIDLabel$, sCurSeparator$ + +Public oNumberFormatter as Object +Public bDebugmode as Boolean +Global GlobListindex as Integer +Public blabla() as String +Public SplitDate as Date +Public oChartSheet as Object +Public oBackgroundSheet as Object +Public Const SBDATECOLUMN = 3 +Public Const SBVALUECOLUMN = 4 +Public Const SBSTARTROW = 25 +Public Const SBCHARTPERIOD = 14 +Public Const SBINTERVAL = "d" +Public sColumnHeader as String +Public StartDate as Date +Public EndDate as Date +Public iCurRow as Integer +Public iMaxRow as Integer +Public iStartDay as Integer +Public iStartMonth as Integer +Public iStartYear as Integer +Public iEndDay as Integer +Public iEndMonth as Integer +Public iEndYear as Integer +Public oStatusLine as Object +Public Today as Date +Public sInterval as String +Public ShortMonths(11,1) +Public iStep as Integer +Public sDepotCurrency as String +Public iValueCol as Integer + +Public DlgReference as Object +Public DlgTransaction as Object +Public DlgStockRates as Object +Public DlgStartUp as Object +Public TransactModel as Object +Public StockRatesModel as Object +Public StartUpModel as Object +Public StockRatesTitle(1 To 3) +Public TransactTitle(1 To 2) +Public NullList() +Public sStartupWelcome$, sStartupChooseMarket$, sStartupHint$ + +Public sMarket(7,10) as String +Public sCountryMarket(7,10) as String + +Public cDlgCaption1$, cDlgCaption2$ +Public sMsgError$, sMsgNoName$, sMsgNoQuantity$, sMsgNoDividend$, sMsgNoExchangeRate$ +Public sMsgNoValidExchangeDate$, sMsgWrongExchangeDate$, sMsgSellTooMuch$, sMsgConfirm$ +Public sMsgFreeStock$, sMsgTotalLoss$, sMsgEndDatebeforeNow$, sMsgStartDatebeforeEndDate$ + +Public sOk$, sCancel$ +Public sMsgAuthorization$, sMsgDeleteAll$ +Public SellMethod$ +Public cSplit$ +Global HistoryChartSource as String +Public DateCellStyle as String +Public CurrCellStyle as String +Public sStartDate$, sEndDate$, sHistory$ +Public sInsertStockname$ +Public sProductname$, sTitle$ +Public sInsertStocks$, sStockname$, sNoInternetUpdate$, sMarketplace$, sNoInternetDataAvailable$ +Public sCheckInternetSettings as String + +Sub LoadLanguage() + LoadDepotDialogs() + Select Case sDocLanguage + Case "de" + LoadGermanLanguage() + Case "en" + LoadEnglishLanguage() + Case "fr" + LoadFrenchLanguage() + Case "it" + LoadItalianLanguage() + Case "es" + LoadSpanishLanguage() + Case "sv" + LoadSwedishLanguage() + Case "ja" + LoadJapaneseLanguage() + Case "ko" + LoadKoreanLanguage() + Case "zh" + If sDocCountry = "CN" Then + LoadChineseSimpleLanguage() + Else + LoadChineseTradLanguage() + End If + End Select + InitializeStartUpModel() +End Sub + +Sub CompleteMarketList() +Dim EuroIndex as Integer +Dim LocCountry as String +Dim LocLanguage as String +Dim sLangList() as String +Dim sCountryList() as String +Dim sExtensionList() as String +Dim MaxIndex as Integer +Dim bIsLocale as Boolean + + GlobListIndex = -1 + For n = 0 To 5 + LocLanguage = sMarket(n,6) + LocCountry = sMarket(n,7) + If Instr(1,LocLanguage,";",SBBINARY) = 0 Then + bIsLocale = CheckDocLocale(LocLanguage, LocCountry) + Else + EuroIndex = 0 + sLangList() = ArrayoutofString(LocLanguage, ";", MaxIndex) + sCountryList() = ArrayoutofString(LocCountry, ";", MaxIndex) + sExtensionList() = ArrayoutofString(sMarket(n,8), ";", MaxIndex) + For m = 0 To MaxIndex + bIsLocale = CheckDocLocale(sLangList(m), sCountryList(m)) + If bIsLocale Then + EuroIndex = m + Exit For + End If + Next m + sMarket(n,6) = sLangList(EuroIndex) + sMarket(n,7) = sCountryList(EuroIndex) + sMarket(n,8) = sExtensionList(EuroIndex) + End If + If bIsLocale Then + GlobListIndex = n + Exit For + End If + Next n +End Sub + +Sub LocalizedCurrencies() + If GlobListIndex = -1 Then + sCountryMarket(0,0) = "Euro" + sCountryMarket(0,1) = chr(8364) + sCountryMarket(0,2) = "Paris" + sCountryMarket(0,3) = "http://fr.finance.yahoo.com/d/quotes.csv?s=<StockID>.PA&f=s4l1t1c1ghov&e=.csv" + sCountryMarket(0,5) = "Code" + sCountryMarket(0,6) = "fr" + sCountryMarket(0,7) = "FR" + sCountryMarket(0,8) = "40C" + sCountryMarket(0,9) = "59/9" + sCountryMarket(0,10) = "1" + + sCountryMarket(1,0) = "Euro" + sCountryMarket(1,1) = chr(8364) + sCountryMarket(1,2) = "Milano" + sCountryMarket(1,3) = "http://it.finance.yahoo.com/d/quotes.csv?s=<StockID>.MI&f=sl1d1t1c1ohgv&e=.csv" + sCountryMarket(1,5) = "Codice" + sCountryMarket(1,6) = "it" + sCountryMarket(1,7) = "IT" + sCountryMarket(1,8) = "410" + sCountryMarket(1,9) = "44" + sCountryMarket(1,10) = "1" + + sCountryMarket(2,0) = "Euro" + sCountryMarket(2,1) = chr(8364) + sCountryMarket(2,2) = "Madrid" + sCountryMarket(2,3) = "http://es.finance.yahoo.com/d/quotes.csv?s=<StockID>&m=MC&f=sl1d1t1c1ohgv&e=.csv" + sCountryMarket(2,5) = "Simbolo" + sCountryMarket(2,6) = "es" + sCountryMarket(2,7) = "ES" + sCountryMarket(2,8) = "40A" + sCountryMarket(2,9) = "44" + sCountryMarket(2,10) = "1" + + sCountryMarket(3,0) = "Dansk krone" + sCountryMarket(3,1) = "kr" + sCountryMarket(3,2) = "København" + sCountryMarket(3,3) = "http://dk.finance.yahoo.com/d/quotes.csv?s=<StockID.CO&f=sl1d1t1c1ohgv&e=.csv" + sCountryMarket(3,5) = "Aktiesymbol" + sCountryMarket(3,6) = "da" + sCountryMarket(3,7) = "DK" + sCountryMarket(3,8) = "406" + sCountryMarket(3,9) = "44" + sCountryMarket(3,10) = "1" + + sCountryMarket(4,0) = "Svensk krona" + sCountryMarket(4,1) = "kr" + sCountryMarket(4,2) = "Stockholm" + sCountryMarket(4,3) = "http://se.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&f=sl1d1t1c1ohgv&e=.c" + sCountryMarket(4,5) = "Kod" + sCountryMarket(4,6) = "sv" + sCountryMarket(4,7) = "SE" + sCountryMarket(4,8) = "41D" + sCountryMarket(4,9) = "44" + sCountryMarket(4,10) = "1" + + ' Taiwan Dollar + sCountryMarket(5,0) = "新臺幣" + sCountryMarket(5,1) = "￥" + sCountryMarket(5,2) = "代號" + sCountryMarket(5,3) = "http://tw.finance.yahoo.com/d/quotes.csv?s=<StockID>.TW&f=sl1d1t1c1ohgv&e=.csv" + sCountryMarket(5,5) = "代號" + sCountryMarket(5,6) = "zh" + sCountryMarket(5,7) = "TW" + sCountryMarket(5,8) = "404" + sCountryMarket(5,9) = "44" + sCountryMarket(5,10) = "1" + + ' Chinese Yuan + sCountryMarket(6,0) = "人民币" + sCountryMarket(6,1) = "￥" + sCountryMarket(6,2) = "代号" + sCountryMarket(6,3) = "http://cn.finance.yahoo.com/d/quotes.csv?s=<StockID>.SS&f=sl1d1t1c1ohgv&e=.csv" + sCountryMarket(6,5) = "代号" + sCountryMarket(6,6) = "zh" + sCountryMarket(6,7) = "CN" + sCountryMarket(6,8) = "804" + sCountryMarket(6,9) = "44" + sCountryMarket(6,10) = "1" + + ' korean Won + sCountryMarket(7,0) = "한국 원화" + sCountryMarket(7,1) = "￦" + sCountryMarket(7,2) = "서울" + sCountryMarket(7,3) = "http://kr.finance.yahoo.com/d/quotes.csv?s=<StockID>.KS&f=snl1d1t1c1ohgv&e=.csv" + sCountryMarket(7,5) = "종목 코드" + sCountryMarket(7,6) = "ko" + sCountryMarket(7,7) = "KR" + sCountryMarket(7,8) = "412" + sCountryMarket(7,9) = "44" + sCountryMarket(7,10) = "2" + + +' sCountryMarket(5,0) = "Российский рубль" +' sCountryMarket(5,1) = "р." +' sCountryMarket(5,2) = "" +' sCountryMarket(5,3) = "" +' sCountryMarket(5,5) = "" +' sCountryMarket(5,6) = "ru" +' sCountryMarket(5,7) = "RU" +' sCountryMarket(5,8) = "-419" +' sCountryMarket(5,9) = "" +' +' sCountryMarket(6,0) = "Złoty polski" +' sCountryMarket(6,1) = "zł" +' sCountryMarket(6,2) = "" +' sCountryMarket(6,3) = "" +' sCountryMarket(6,5) = "" 'Still Todo!! +' sCountryMarket(6,6) = "pl" +' sCountryMarket(6,7) = "PL" +' sCountryMarket(6,8) = "-415" +' sCountryMarket(6,9) = "" +' +' sCountryMarket(7,0) = "Türkische Lira" +' sCountryMarket(7,1) = "TL" +' sCountryMarket(7,2) = "" +' sCountryMarket(7,3) = "" +' sCountryMarket(7,5) = "" 'Still Todo!! +' sCountryMarket(7,6) = "tr" +' sCountryMarket(7,7) = "TR" +' sCountryMarket(7,8) = "-41F" +' sCountryMarket(7,9) = "" + + Dim n as Integer + Dim m as Integer +' Dim sCountryMarket(6,9) as String + + For n = 0 To Ubound(sCountryMarket(),1) + If sDocLanguage = sCountryMarket(n,6) and sDocCountry = sCountryMarket(n,7) Then + GlobListIndex = 6 + For m = 0 To 10 + sMarket(6,m) = sCountryMarket(n,m) + Next m + Exit For + End If + Next n + End If +End Sub + +Sub LoadDepotDialogs() + DlgTransaction = LoadDialog("Depot", "Dialog2") + DlgStockRates = LoadDialog("Depot", "Dialog3") + DlgStartUp = LoadDialog("Depot", "Dialog4") + TransactModel = DlgTransaction.Model + StockRatesModel = DlgStockRates.Model + StartUpModel = DlgStartUp.Model +End Sub + + +Sub InitializeStartUpModel() + With StartUpModel + .lblWelcome.Label = sStartupWelcome & Chr(13) & chr(13) & sStartUpChooseMarket + sStartUpHint = ReplaceString(sStartUpHint, sHistory, "<History>") + .lblHint.Label = sStartupHint +' .cmdGoOn.Enabled = Ubound(StartUpModel.lstMarkets.SelectedItems()) <> -1 + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With +End Sub diff --git a/wizards/source/depot/Currency.xba b/wizards/source/depot/Currency.xba new file mode 100644 index 000000000..d728424d3 --- /dev/null +++ b/wizards/source/depot/Currency.xba @@ -0,0 +1,195 @@ + + + +REM ***** BASIC ***** +Option Explicit + +Dim bDoUnLoad as Boolean + + +Sub Startup() +Dim i as Integer +Dim a as Integer +Dim ListString as String +Dim MarketListBoxControl as Object + Initialize(False) + MarketListBoxControl = DlgStartUp.GetControl("lstMarkets") + a = 0 + For i = 0 To Ubound(sMarket(),1) + ListString = sMarket(i,0) + If sMarket(i,0) <> "" Then + If sMarket(i,3) = "" Then + ListString = ListString & " (" & sNoInternetUpdate & ")" + Else + ListString = ListString & " (" & sMarketplace & " " & sMarket(i,2) & ")" + End If + MarketListBoxControl.AddItem(ListString, a) + a = a + 1 + End If + Next i + MarketListBoxControl.SelectItemPos(GlobListIndex, True) + DlgStartUp.Title = sDepotCurrency + DlgStartUp.Model.cmdGoOn.DefaultButton = True + DlgStartUp.GetControl("lstMarkets").SetFocus() + DlgStartUp.Execute() + DlgStartUp.Dispose() +End Sub + + +Sub EnableGoOnButton() + StartUpModel.cmdGoOn.Enabled = True + StartUpModel.cmdGoOn.DefaultButton = True +End Sub + + +Sub CloseStartUpDialog() + DlgStartUp.EndExecute() +' oDocument.Dispose() +End Sub + + +Sub DisposeDocument() + If bDoUnload Then + oDocument.Dispose() + End If +End Sub + + +Sub ChooseMarket(Optional aEvent) +Dim Index as Integer +Dim bIsDocLanguage as Boolean +Dim bIsDocCountry as Boolean + oInternetModel = GetControlModel(oDocument.Sheets(0), "CmdInternet") + If Not IsMissing(aEvent) Then + Index = StartupModel.lstMarkets.SelectedItems(0) + oInternetModel.Tag = Index + Else + Index = oInternetModel.Tag + End If + oMarketModel = GetControlModel(oDocument.Sheets(0), "CmdHistory") + sCurCurrency = sMarket(Index,1) + If Index = 0 Then + HistoryChartSource = sMarket(Index,4) + End If + sCurStockIDLabel = sMarket(Index,5) + sCurExtension = sMarket(Index,8) + iValueCol = Val(sMarket(Index,10)) + If Instr(sCurExtension,";") <> 0 Then + ' Take the german extension as the stock place is Frankfurt + sCurExtension = "407" + End If + sCurChartSource = sMarket(Index,3) + bIsDocLanguage = Instr(1, sMarket(Index,6), sDocLanguage, SBBINARY) <> 0 + bIsDocCountry = Instr(1, sMarket(Index,7), sDocCountry, SBBINARY) <> 0 OR SDocCountry = "" + sCurSeparator = sMarket(Index,9) + TransactModel.txtRate.CurrencySymbol = sCurCurrency + TransactModel.txtFix.CurrencySymbol = sCurCurrency + TransactModel.txtMinimum.CurrencySymbol = sCurCurrency + bEnableMarket = Index = 0 + bEnableInternet = sCurChartSource <> "" + oMarketModel.Enabled = bEnableMarket + oInternetModel.Enabled = bEnableInternet + If Not IsMissing(aEvent) Then + ConvertStylesCurrencies() + bDoUnload = False + DlgStartUp.EndExecute() + End If +End Sub + + +Sub ConvertStylesCurrencies() +Dim m as integer +Dim aStyleFormat as Object +Dim StyleName as String +Dim bAddToList as Boolean +Dim oStyle as Object +Dim oStyles as Object + UnprotectSheets(oSheets) + oFirstSheet.GetCellByPosition(SBCOLUMNID1, SBROWHEADER1).SetString(sCurStockIDLabel) + oStyles = oDocument.StyleFamilies.GetbyIndex(0) + For m = 0 To oStyles.count-1 + oStyle = oStyles.GetbyIndex(m) + StyleName = oStyle.Name + bAddToList = CheckFormatType(oStyle) + If bAddToList Then + SwitchNumberFormat(ostyle, oDocFormats, sCurCurrency, sCurExtension) + End If + Next m + ProtectSheets(oSheets) +End Sub + + +Sub SwitchNumberFormat(oObject as Object, oFormats as object, sNewSymbol as String, sNewExtension as String) +Dim nFormatLanguage as Integer +Dim nFormatDecimals as Integer +Dim nFormatLeading as Integer +Dim bFormatLeading as Integer +Dim bFormatNegRed as Integer +Dim bFormatThousands as Integer +Dim aNewStr as String +Dim iNumberFormat as Long +Dim sSimpleStr as String +Dim nSimpleKey as Long +Dim aFormat() +Dim oLocale as New com.sun.star.lang.Locale + ' Numberformat with the new Symbol as Base for new Format + sSimpleStr = "0 [$" & sNewSymbol & "-" & sNewExtension & "]" + nSimpleKey = Numberformat(oFormats, sSimpleStr, oDocLocale) + On Local Error Resume Next + iNumberFormat = oObject.NumberFormat + If Err <> 0 Then + Msgbox "Error Reading the Number Format" + Resume CLERROR + End If + + On Local Error GoTo NOKEY + aFormat() = oFormats.getByKey(iNumberFormat) + On Local Error GoTo 0 + ' set new currency format with according settings + nFormatDecimals = aFormat.Decimals + nFormatLeading = aFormat.LeadingZeros + bFormatNegRed = aFormat.NegativeRed + bFormatThousands = aFormat.ThousandsSeparator + oLocale = aFormat.Locale + aNewStr = oFormats.generateFormat(nSimpleKey, oLocale, bFormatThousands, bFormatNegRed, nFormatDecimals, nFormatLeading) + oObject.NumberFormat = Numberformat(oFormats, aNewStr, oLocale) + NOKEY: + If Err <> 0 Then + Resume CLERROR + End If + CLERROR: +End Sub + + +Function Numberformat( oFormats as Object, aFormatStr as String, oLocale as Variant ) +Dim nRetkey + nRetKey = oFormats.queryKey(aFormatStr, oLocale, True) + If nRetKey = -1 Then + nRetKey = oFormats.addNew( aFormatStr, oLocale ) + If nRetKey = -1 Then nRetKey = 0 + End If + Numberformat = nRetKey +End Function + + +Function CheckFormatType(oStyle as Object) +Dim oFormatofObject as Object + oFormatofObject = oDocFormats.getByKey(oStyle.NumberFormat) + CheckFormatType = INT(oFormatOfObject.Type) AND com.sun.star.util.NumberFormat.CURRENCY +End Function diff --git a/wizards/source/depot/Depot.xba b/wizards/source/depot/Depot.xba new file mode 100644 index 000000000..6a8b1419c --- /dev/null +++ b/wizards/source/depot/Depot.xba @@ -0,0 +1,517 @@ + + + +Option Explicit + + +Sub Initialize(Optional bChooseMarketPlace as Boolean) +Dim bEnableHistory as Boolean + GlobalScope.BasicLibraries.LoadLibrary("Tools") +' oMarketModel = GetControlModel(oDocument.Sheets(0), "CmdHistory") +' bEnableHistory = oMarketModel.Enabled + ToggleWindow(False) + Today = Date() + bDebugmode = False + oDocument = ThisComponent + oController = oDocument.GetCurrentController + oSheets = oDocument.Sheets + oFirstSheet = oSheets(0) + oMovementSheet = oSheets(1) + oBankSheet = oSheets(2) + oDocFormats = oDocument.NumberFormats + oNumberFormatter = CreateUnoService("com.sun.star.util.NumberFormatter") + oNumberFormatter.AttachNumberFormatsSupplier(oDocument) + oDocLocale = oDocument.CharLocale + sDocLanguage = oDocLocale.Language + sDocCountry = oDocLocale.Country + LoadLanguage() + ToggleWindow(True) +' oMarketModel.Enabled = bEnableHistory + If Not IsMissing(bChooseMarketPlace) Then + If bChoosemarketPlace Then + ChooseMarket() + End If + Else + ChooseMarket() + End If + If Not IsMissing(bChooseMarketPlace) Then + If bChooseMarketPlace Then + oMarketModel.Enabled = bEnableMarket + oInternetModel.Enabled = bEnableInternet + End If + End If +End Sub + + +Sub Buy() + Initialize(True) + FillListbox(DlgTransaction.GetControl("lstBuyStocks"), TransactTitle(SBDIALOGBUY), False) + SetupTransactionControls(SBDIALOGBUY) + EnableTransactionControls(False) + DlgTransaction.Execute() +End Sub + + +Sub Sell() + Initialize(True) + If FillListbox(DlgTransaction.GetControl("lstSellStocks"), TransactTitle(SBDIALOGSELL), True) Then + SetupTransactionControls(SBDIALOGSELL) + EnableTransactionControls(False) + DlgTransaction.Execute() + End If +End Sub + + +Sub Reset() +Dim TransactionCount as Integer +Dim StockCount, iStartRow, i as Integer +Dim oRows, oRange as Object +Dim StockName as String + Initialize(True) + ' Delete transactions and reset overview + If MsgBox(sMsgDeleteAll, SBMSGYESNO+SBMSGQUESTION+SBMSGDEFAULTBTN2, sMsgAuthorization) = 6 Then + ' Assumption: If and only if there is an overview, then there are transactions, too + UnprotectSheets(oSheets) + StockCount = GetStocksCount(iStartRow) + + For i = 1 To StockCount + StockName = oFirstSheet.GetCellbyPosition(SBCOLUMNNAME1, iStartRow + i).String + If oSheets.HasbyName(StockName) Then + oSheets.RemoveByName(StockName) + End If + Next + oDocument.AddActionLock + RemoveStockRows(oFirstSheet, iStartRow + 1, StockCount) + TransactionCount = GetTransactionCount(iStartRow) + RemoveStockRows(oMovementSheet, iStartRow + 2, TransactionCount) + ProtectSheets(oSheets) + oDocument.RemoveActionLock + End If +End Sub + + +Sub TransactionOk +Dim Sold as Long +Dim RestQuantity, Value, PartialValue, Profit +Dim iNewRow as Integer, iRow as Integer +Dim iStockRow as Long, iRestQuantity as Long +Dim oNameCell as Object +Dim CellStockName as String, SelStockName as String +Dim CurRate as Double +Dim TransactDate as Date +Dim LocStockName as String + ' Check for rate entered + If TransactModel.txtRate.Value = 0 Then + If TransactModel.Step = SBDIALOGBUY Then + If MsgBox(sMsgFreeStock, SBMSGYESNO+SBMSGQUESTION, sMsgConfirm)=7 Then + Exit Sub + End If + Else + If MsgBox(sMsgTotalLoss, SBMSGYESNO+SBMSGQUESTION, sMsgConfirm)=7 Then + Exit Sub + End If + End If + End If + CurRate = TransactModel.txtRate.Value + TransactDate = CDateFromUNODate(TransactModel.txtDate.Date) + DlgTransaction.EndExecute() + UnprotectSheets(oSheets) + + iNewRow = DuplicateRow(oMovementSheet, "HiddenRow3") + + If TransactModel.Step = SBDIALOGBUY Then + CellStockName = TransactModel.lstBuyStocks.Text + If Instr(1,CellStockName,"$") <> 0 Then + CellStockName = "'" & CellStockName & "'" + End If + oMovementSheet.GetCellByPosition(SBCOLUMNNAME2, iNewRow).String = CellStockName + oMovementSheet.GetCellByPosition(SBCOLUMNQUANTITY2, iNewRow).Value = TransactModel.txtQuantity.Value + Else + CellStockName = DlgTransaction.GetControl("lstSellStocks").GetSelectedItem() + oMovementSheet.GetCellByPosition(SBCOLUMNNAME2, iNewRow).String = CellStockName + oMovementSheet.GetCellByPosition(SBCOLUMNQUANTITY2, iNewRow).Value = -TransactModel.txtQuantity.Value + End If + + oMovementSheet.GetCellByPosition(SBCOLUMNDATE2, iNewRow).Value = CDateFromUNODate(TransactModel.txtDate.Date) + oMovementSheet.GetCellByPosition(SBCOLUMNRATE2, iNewRow).Value = TransactModel.txtRate.Value + oMovementSheet.GetCellByPosition(SBCOLUMNPROVPERCENT2, iNewRow).Value = TransactModel.txtCommission.EffectiveValue + oMovementSheet.GetCellByPosition(SBCOLUMNPROVMIN2, iNewRow).Value = TransactModel.txtMinimum.Value + oMovementSheet.GetCellByPosition(SBCOLUMNPROVFIX2, iNewRow).Value = TransactModel.txtFix.Value + + ' Buy stocks: Update overview for new stocks + If TransactModel.Step = SBDIALOGBUY Then + iStockRow = GetStockRowIndex(CellStockName) + If iStockRow = -1 Then + iNewRow = DuplicateRow(oFirstSheet, "HiddenRow2") + oFirstSheet.GetCellByPosition(SBCOLUMNNAME1, iNewRow).String = CellStockName + oFirstSheet.GetCellByPosition(SBCOLUMNID1, iNewRow).String = TransactModel.txtStockID.Text + iStockRow = GetStockRowIndex(CellStockName) + End If + ' Sell stocks: Get transaction value, then update Transaction sheet + ElseIf TransactModel.Step = SBDIALOGSELL Then + Profit = oMovementSheet.GetCellByPosition(SBCOLUMNPROCEEDS2, iNewRow).Value + Value = Profit + Sold = TransactModel.txtQuantity.Value + SelStockName = DlgTransaction.GetControl("lstSellStocks").GetSelectedItem() + ' Go to first name + If TransactMode = FIFO Then + iRow = SBROWFIRSTTRANSACT2 + Else + iRow = iNewRow-1 + End If + + ' Check that no transaction after split date exists else cancel split + Do While Sold > 0 + oNameCell = oMovementSheet.GetCellByPosition(SBCOLUMNNAME2, iRow) + CellStockName = oNameCell.String + If CellStockName = SelStockName Then + ' Update transactions: Note quantity sold + RestQuantity = oMovementSheet.GetCellByPosition(SBCOLUMNQTYREST2, iRow).Value + ' If there still is a rest left ... + If RestQuantity > 0 Then + If RestQuantity < Sold Then + ' Recalculate profit of new transaction + Profit = Profit - oMovementSheet.GetCellByPosition(SBCOLUMNPRCREST2, iRow).Value + AddValueToCellContent(SBCOLUMNQTYSOLD2, iRow, RestQuantity) + PartialValue = RestQuantity / Sold * Value + AddValueToCellContent(SBCOLUMNREALPROC2, iRow, PartialValue) + Sold = Sold - RestQuantity + Value = Value - PartialValue + Else + ' Recalculate profit of neTransactModel.lstBuyStocks.Textw transaction + PartialValue = oMovementSheet.GetCellByPosition(SBCOLUMNPRCREST2, iRow).Value + Profit = Profit - PartialValue/RestQuantity * Sold + ' Update sold shares cell + AddValueToCellContent(SBCOLUMNQTYSOLD2, iRow, Sold) + ' Update sales turnover cell + AddValueToCellContent(SBCOLUMNREALPROC2, iRow, Value) + ' Update variables for rest of transaction + Sold = 0 + Value = 0 + End If + End If + End If + iRow = iRow + TransactMode + Loop + oMovementSheet.GetCellByPosition(SBCOLUMNREALPROFIT2,iNewRow).Value = Profit + iStockRow = GetStockRowIndex(SelStockName) + iRestQuantity = oFirstSheet.GetCellbyPosition(SBCOLUMNQUANTITY1, iStockRow).Value +' If iRestQuantity = 0 Then +' If oSheets.HasbyName(SelStockName) Then +' oSheets.RemoveByName(SelStockName) +' End If +' Else + +' End If + End If + InsertCurrentValue(CurRate, iStockRow,TransactDate) + ProtectSheets(oSheets) +End Sub + + +Sub SelectStockname(aEvent as Object) +Dim iCurRow as Integer +Dim CurStockName as String + With TransactModel + ' Find row with stock name + If TransactModel.Step = SBDIALOGBUY Then + CurStockName = .lstBuyStocks.Text + iCurRow = GetStockRowIndex(CurStockName) + .txtQuantity.ValueMax = 10000000 + Else + Dim ListBoxList() as String + ListBoxList() = GetSelectedListboxItems(aEvent.Source.getModel()) + CurStockName = ListBoxList(0) +' CurStockName = DlgTransaction.GetControl(aEvent.Source.getModel.Name).GetSelectedItem() + iCurRow = GetStockRowIndex(CurStockName) + Dim fdouble as Double + fdouble = oFirstSheet.GetCellByPosition(SBCOLUMNQUANTITY1, iCurRow).Value + .txtQuantity.Value = fdouble + .txtQuantity.ValueMax = oFirstSheet.GetCellByPosition(SBCOLUMNQUANTITY1, iCurRow).Value + .txtRate.Value = oFirstSheet.GetCellbyPosition(SBCOLUMNRATE1, iCurRow).Value + End If + .txtStockID.Enabled = .Step = SBDIALOGBUY + .lblStockID.Enabled = .Step = SBDIALOGBUY + ' Default settings for quantity and rate + .txtStockID.Text = GetStockID(CurStockName, iCurRow) + End With + EnableTransactionControls(CurStockName <> "") + TransactModel.cmdGoOn.DefaultButton = True +End Sub + + + +Sub HandleStocks(Mode as Integer, oDialog as Object) +Dim DividendPerShare, DividendTotal, RestQuantity, OldValue +Dim SelStockName, CellStockName as String +Dim oNameCell as Object, oDateCell as Object +Dim iRow as Integer +Dim oDividendCell as Object +Dim Amount +Dim OldNumber, NewNumber as Integer +Dim NoteText as String +Dim TotalStocksCount as Long +Dim oModel as Object + oDocument.AddActionLock + oDialog.EndExecute() + oModel = oDialog.Model + SelStockName = DlgStockRates.GetControl("lstStockNames").GetSelectedItem() + Select Case Mode + Case HANDLEDIVIDEND + Dim bTakeTotal as Boolean + ' Update transactions: Enter dividend paid for all Buy transactions not sold completely + bTakeTotal = oModel.optTotal.State = 1 + If bTakeTotal Then + DividendTotal = oModel.txtDividend.Value + iRow = GetStockRowIndex(SelStockName) + TotalStocksCount = oFirstSheet.GetCellByPosition(SBCOLUMNQUANTITY1,iRow).Value + DividendPerShare = DividendTotal/TotalStocksCount + Else + DividendPerShare = oModel.txtDividend.Value + End If + + Case HANDLESPLIT + ' Store entered values in variables + OldNumber = oModel.txtOldRate.Value + NewNumber = oModel.txtNewRate.Value + SplitDate = CDateFromUNODate(oModel.txtDate.Date) + iRow = SBROWFIRSTTRANSACT2 + NoteText = cSplit & SplitDate & ", " & oModel.txtOldRate.Value & oModel.lblColon.Label & oModel.txtNewRate.Value + Do + oNameCell = oMovementSheet.GetCellByPosition(SBCOLUMNNAME2, iRow) + CellStockName = oNameCell.String + If CellStockName = SelStockName Then + oDateCell = oMovementSheet.GetCellByPosition(SBCOLUMNDATE2, iRow) + If oDateCell.Value >= SplitDate Then + MsgBox sMsgWrongExchangeDate, SBMSGOK + SBMSGSTOP, sMsgError + Exit Sub + End If + End If + iRow = iRow + 1 + Loop Until CellStockName = "" + End Select + iRow = SBROWFIRSTTRANSACT2 + UnprotectSheets(oSheets) + Do + oNameCell = oMovementSheet.GetCellByPosition(SBCOLUMNNAME2, iRow) + CellStockName = oNameCell.String + If CellStockName = SelStockName Then + Select Case Mode + Case HANDLEDIVIDEND + RestQuantity = oMovementSheet.GetCellByPosition(SBCOLUMNQTYREST2, iRow).Value + If RestQuantity > 0 Then + oDividendCell = oMovementSheet.GetCellByPosition(SBCOLUMNDIVIDEND2, iRow) + OldValue = oDividendCell.Value + oDividendCell.Value = OldValue + RestQuantity * DividendPerShare + End If + Case HANDLESPLIT + oDateCell = oMovementSheet.GetCellByPosition(SBCOLUMNDATE2, iRow) + SplitCellValue(oMovementSheet, NewNumber, OldNumber, SBCOLUMNQUANTITY2, iRow, NoteText) + SplitCellValue(oMovementSheet, OldNumber, NewNumber, SBCOLUMNRATE2, iRow, "") + SplitCellValue(oMovementSheet, NewNumber, OldNumber, SBCOLUMNQTYSOLD2, iRow, "") + End Select + End If + iRow = iRow + 1 + Loop Until CellStockName = "" + If Mode = HANDLESPLIT Then + CalculateChartafterSplit(SelStockName, NewNumber, OldNumber, NoteText, SplitDate) + End If + oDocument.CalculateAll() + ProtectSheets(oSheets) + oDocument.RemoveActionLock +End Sub + + +Sub CancelStockRate() + DlgStockRates.EndExecute() +End Sub + + +Sub CancelTransaction() + DlgTransaction.EndExecute() +End Sub + + +Sub CommitStockRate() +Dim CurStep as Integer + CurStep = StockRatesModel.Step + Select Case CurStep + Case 1 + ' Check for quantity entered + If StockRatesModel.txtDividend.Value = 0 Then + MsgBox sMsgNoDividend, SBMSGSTOP+SBMSGSTOP, sMsgError + Exit Sub + End If + HandleStocks(HANDLEDIVIDEND, DlgStockRates) + Case 2 + HandleStocks(HANDLESPLIT, DlgStockRates) + Case 3 + InsertCompanyHistory() + End Select +End Sub + + +Sub EnableTransactionControls(bEnable as Boolean) + With TransactModel + .lblQuantity.Enabled = bEnable + .txtQuantity.Enabled = bEnable + .lblRate.Enabled = bEnable + .txtRate.Enabled = bEnable + .lblDate.Enabled = bEnable + .txtDate.Enabled = bEnable + .lblCommission.Enabled = bEnable + .txtCommission.Enabled = bEnable + .lblMinimum.Enabled = bEnable + .txtMinimum.Enabled = bEnable + .lblFix.Enabled = bEnable + .txtFix.Enabled = bEnable + If TransactModel.Step = SBDIALOGSELL Then + .cmdGoOn.Enabled = Ubound(TransactModel.lstSellStocks.SelectedItems()) > -1 + DlgTransaction.GetControl("lstSellStocks").SetFocus() + Else + .cmdGoOn.Enabled = TransactModel.lstBuyStocks.Text <> "" + DlgTransaction.GetControl("lstBuyStocks").SetFocus() + End If + If bEnable Then + TransactModel.cmdGoOn.DefaultButton = True + End If + End With +End Sub + + +Sub SetupTransactionControls(CurStep as Integer) + DlgReference = DlgTransaction + With TransactModel + .txtDate.Date = CDateToUNODate(Date()) + .txtDate.DateMax = CDateToUNODate(Date()) + .txtStockID.Enabled = False + .lblStockID.Enabled = False + .lblStockID.Label = sCurStockIDLabel + .txtRate.CurrencySymbol = sCurCurrency + .txtFix.CurrencySymbol = sCurCurrency + .Step = CurStep + End With + DlgTransaction.Title = TransactTitle(CurStep) + CellValuetoControl(oBankSheet, TransactModel.txtCommission, "ProvisionPercent") + CellValuetoControl(oBankSheet, TransactModel.txtMinimum, "ProvisionMinimum") + CellValuetoControl(oBankSheet, TransactModel.txtFix, "ProvisionFix") +End Sub + + +Sub AddShortCuttoControl() +Dim SelCompany as String +Dim iRow, SelIndex as Integer + SelIndex = DlgTransaction.GetControl("lstBuyStocks").GetSelectedItemPos() + If SelIndex <> -1 Then + SelCompany = TransactModel.lstBuyStocks.StringItemList(SelIndex) + iRow = GetStockRowIndex(SelCompany) + If iRow <> -1 Then + TransactModel.txtStockID.Text = oFirstSheet.GetCellByPosition(SBCOLUMNID1,iRow).String + TransactModel.txtRate.Value = oFirstSheet.GetCellByPosition(SBCOLUMNRATE1,iRow).Value + Else + TransactModel.txtStockID.Text = "" + TransactModel.txtRate.Value = 0 + End If + Else + TransactModel.txtStockID.Text = "" + TransactModel.txtRate.Value = 0 + End If +End Sub + + +Sub OpenStockRatePage(aEvent) +Dim CurStep as Integer + Initialize(True) + CurStep = aEvent.Source.Model.Tag + If FillListbox(DlgStockRates.GetControl("lstStockNames"), StockRatesTitle(CurStep), True) Then + StockRatesModel.Step = CurStep + ToggleStockRateControls(False, CurStep) + InitializeStockRatesControls(CurStep) + DlgStockRates.Execute() + End If +End Sub + + +Sub SelectStockNameForRates() +Dim StockName as String + StockName = DlgStockRates.GetControl("lstStockNames").GetSelectedItem() + If StockName <> "" Then + StockRatesModel.txtStockID.Text = GetStockID(StockName) + ToggleStockRateControls(True, StockRatesModel.Step) + End If + StockRatesModel.cmdGoOn.DefaultButton = True +End Sub + + +Sub ToggleStockRateControls(bDoEnable as Boolean, CurStep as Integer) + With StockRatesModel + .lblStockID.Enabled = False + .txtStockID.Enabled = False + .cmdGoOn.Enabled = Ubound(StockRatesModel.lstStockNames.SelectedItems()) <> -1 + Select Case CurStep + Case 1 + .optPerShare.Enabled = bDoEnable + .optTotal.Enabled = bDoEnable + .lblDividend.Enabled = bDoEnable + .txtDividend.Enabled = bDoEnable + Case 2 + .lblExchangeRate.Enabled = bDoEnable + .lblDate.Enabled = bDoEnable + .lblColon.Enabled = bDoEnable + .txtOldRate.Enabled = bDoEnable + .txtNewRate.Enabled = bDoEnable + .txtDate.Enabled = bDoEnable + Case 3 + .lblStartDate.Enabled = bDoEnable + .lblEndDate.Enabled = bDoEnable + .txtStartDate.Enabled = bDoEnable + .txtEndDate.Enabled = bDoEnable + .hlnInterval.Enabled = bDoEnable + .optDaily.Enabled = bDoEnable + .optWeekly.Enabled = bDoEnable + End Select + End With +End Sub + + +Sub InitializeStockRatesControls(CurStep as Integer) + DlgReference = DlgStockRates + DlgStockRates.Title = StockRatesTitle(CurStep) + With StockRatesModel + .txtStockID.Text = "" + .lblStockID.Label = sCurStockIDLabel + Select Case CurStep + Case 1 + .txtDividend.Value = 0 + .optPerShare.State = 1 + .txtDividend.CurrencySymbol = sCurCurrency + Case 2 + .txtOldRate.Value = 1 + .txtNewRate.Value = 1 + .txtDate.Date = CDateToUNODate(Date()) + Case 3 + .txtStartDate.DateMax = CDateToUNODate(CDate(Date())-1) + .txtEndDate.DateMax = CDateToUNODate(CDate(Date())-1) + .txtStartDate.Date = CDateToUNODate(CDate(Date())-8) + .txtEndDate.Date = CDateToUNODate(CDate(Date())-1) + .optDaily.State = 1 + End Select + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Dialog2.xdl b/wizards/source/depot/Dialog2.xdl new file mode 100644 index 000000000..94851c3e4 --- /dev/null +++ b/wizards/source/depot/Dialog2.xdl @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/depot/Dialog3.xdl b/wizards/source/depot/Dialog3.xdl new file mode 100644 index 000000000..3b8904700 --- /dev/null +++ b/wizards/source/depot/Dialog3.xdl @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/depot/Dialog4.xdl b/wizards/source/depot/Dialog4.xdl new file mode 100644 index 000000000..057eb9d17 --- /dev/null +++ b/wizards/source/depot/Dialog4.xdl @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/depot/Internet.xba b/wizards/source/depot/Internet.xba new file mode 100644 index 000000000..d3393bc72 --- /dev/null +++ b/wizards/source/depot/Internet.xba @@ -0,0 +1,356 @@ + + + +REM ***** BASIC ***** +Option Explicit +Public sNewSheetName as String + +Function CheckHistoryControls() +Dim bLocGoOn as Boolean +Dim Firstdate as Date +Dim LastDate as Date + LastDate = CDateFromUNODate(StockRatesModel.txtEndDate.Date) + FirstDate = CDateFromUNODate(StockRatesModel.txtStartDate.Date) + bLocGoOn = FirstDate <> 0 And LastDate <> 0 + If bLocGoOn Then + If FirstDate >= LastDate Then + Msgbox(sMsgStartDatebeforeEndDate,16, sProductname) + bLocGoOn = False + End If + End If + CheckHistoryControls = bLocGoon +End Function + + +Sub InsertCompanyHistory() +Dim StockName as String +Dim CurRow as Integer +Dim sMsgInternetError as String +Dim CurRate as Double +Dim oCell as Object +Dim sStockID as String +Dim ChartSource as String + If CheckHistoryControls() Then + StartDate = CDateFromUNODate(StockRatesModel.txtStartDate.Date) + EndDate = CDateFromUNODate(StockRatesModel.txtEndDate.Date) + DlgStockRates.EndExecute() + If StockRatesModel.optDaily.State = 1 Then + sInterval = "d" + iStep = 1 + ElseIf StockRatesModel.optWeekly.State = 1 Then + sInterval = "w" + iStep = 7 + StartDate = StartDate - WeekDay(StartDate) + 2 + EndDate = EndDate - WeekDay(EndDate) + 2 + End If + iEndDay = Day(EndDate) + iEndMonth = Month(EndDate) + iEndYear = Year(EndDate) + iStartDay = Day(StartDate) + iStartMonth = Month(StartDate) + iStartYear = Year(StartDate) +' oDocument.AddActionLock() + UnprotectSheets(oSheets) + InitializeStatusline("", 10, 1) + oBackGroundSheet = oSheets.GetbyName("Background") + StockName = DlgStockRates.GetControl("lstStockNames").GetSelectedItem() + CurRow = GetStockRowIndex(Stockname) + sStockID = oFirstSheet.GetCellByPosition(SBCOLUMNID1, CurRow).String + ChartSource = ReplaceString(HistoryChartSource, sStockID, "<StockID>") + ChartSource = ReplaceString(ChartSource, iStartDay, "<StartDay>") + ChartSource = ReplaceString(ChartSource, cStr(iStartMonth-1), "<StartMonth>") + ChartSource = ReplaceString(ChartSource, iStartYear, "<StartYear>") + ChartSource = ReplaceString(ChartSource, iEndDay, "<EndDay>") + ChartSource = ReplaceString(ChartSource, cStr(iEndMonth-1), "<EndMonth>") + ChartSource = ReplaceString(ChartSource, iEndYear, "<EndYear>") + ChartSource = ReplaceString(ChartSource, sInterval, "<interval>") + oStatusLine.SetValue(2) + If GetCurrentRate(ChartSource, CurRate, 1) Then + oStatusLine.SetValue(8) + UpdateValue(StockName, Today, CurRate) + oStatusLine.SetValue(9) + UpdateChart(StockName) + oStatusLine.SetValue(10) + Else + sMsgInternetError = Stockname & ": " & sNoInternetDataAvailable & chr(13) & sCheckInternetSettings + Msgbox(sMsgInternetError, 16, sProductname) + End If + ProtectSheets(oSheets) + oStatusLine.End + If oSheets.HasbyName(sNewSheetName) Then + oController.ActiveSheet = oSheets.GetByName(sNewSheetName) + End If +' oDocument.RemoveActionLock() + End If +End Sub + + + +Sub InternetUpdate() +Dim i as Integer +Dim StocksCount as Integer +Dim iStartRow as Integer +Dim sUrl as String +Dim StockName as String +Dim CurRate as Double +Dim oCell as Object +Dim sMsgInternetError as String +Dim sStockID as String +Dim ChartSource as String +' oDocument.AddActionLock() + Initialize(True) + UnprotectSheets(oSheets) + StocksCount = GetStocksCount(iStartRow) + InitializeStatusline("", StocksCount + 1, 1) + Today = CDate(Date) + For i = iStartRow + 1 To iStartRow + StocksCount + StockName = oFirstSheet.GetCellbyPosition(SBCOLUMNNAME1, i).String + sStockID = oFirstSheet.GetCellByPosition(SBCOLUMNID1, i).String + ChartSource = ReplaceString(sCurChartSource, sStockID, "<StockID>") + If GetCurrentRate(ChartSource, CurRate, 0) Then + InsertCurrentValue(CurRate, i, Now) + Else + sMsgInternetError = Stockname & ": " & sNoInternetDataAvailable & chr(13) & sCheckInternetSettings + Msgbox(sMsgInternetError, 16, sProductname) + End If + oStatusline.SetValue(i - iStartRow + 1) + Next + ProtectSheets(oSheets) + oStatusLine.End +' oDocument.RemoveActionLock +End Sub + + + +Function GetCurrentRate(sUrl as String, fValue As Double, iValueRow as Integer) as Boolean +Dim sFilter As String +Dim sOptions As String +Dim oLinkSheet As Object +Dim sDate as String + If oSheets.hasByName("Link") Then + oLinkSheet = oSheets.getByName("Link") + Else + oLinkSheet = oDocument.createInstance("com.sun.star.sheet.Spreadsheet") + oSheets.insertByName("Link", oLinkSheet) + oLinkSheet.IsVisible = False + End If + + sFilter = "Text - txt - csv (StarCalc)" + sOptions = sCurSeparator & ",34,SYSTEM,1,1/10/2/10/3/10/4/10/5/10/6/10/7/10/8/10/9/10" + + oLinkSheet.LinkMode = com.sun.star.sheet.SheetLinkMode.NONE + oLinkSheet.link(sUrl, "", sFilter, sOptions, 1 ) + fValue = oLinkSheet.getCellByPosition(iValueCol, iValueRow).Value + If fValue = 0 Then + Dim sValue as String + sValue = oLinkSheet.getCellByPosition(1, iValueRow).String + sValue = ReplaceString(sValue, ".",",") + fValue = Val(sValue) + End If + GetCurrentRate = fValue <> 0 +End Function + + + +Sub UpdateValue(ByVal sName As String, fDate As Double, fValue As Double ) +Dim oSheet As Object +Dim iColumn As Long +Dim iRow As Long +Dim i as Long +Dim oCell As Object +Dim LastDate as Date +Dim bLeaveLoop as Boolean +Dim RemoveCount as Long +Dim iLastRow as Long +Dim iLastLinkRow as Long +Dim dDate as Date +Dim CurDate as Date +Dim oLinkSheet as Object +Dim StartIndex as Long +Dim iCellValue as Long + ' Insert Sheet with Company - Chart + sName = CheckNewSheetname(oSheets, sName) + If NOT oSheets.hasByName(sName) Then + oSheets.CopybyName("Background", sName, oSheets.Count) + oSheet = oSheets.getByName(sName) + iCurRow = SBSTARTROW + iMaxRow = iCurRow + oCell = oSheet.getCellByPosition(SBDATECOLUMN, iCurRow) + oCell.Value = fDate + End If + sNewSheetName = sName + oLinkSheet = oSheets.GetByName("Link") + oSheet = oSheets.getByName(sName) + iLastRow = GetLastUsedRow(oSheet)- 2 + iLastLinkRow = GetLastUsedRow(oLinkSheet) + iCurRow = iLastRow + bLeaveLoop = False + RemoveCount = 0 + ' Delete all Cells in Date Area + Do + oCell = oSheet.GetCellbyPosition(SBDATECOLUMN,iCurRow) + If oCell.CellStyle = sColumnHeader Then + bLeaveLoop = True + StartIndex = iCurRow + iCurRow = iCurRow + 1 + Else + RemoveCount = RemoveCount + 1 + iCurRow = iCurRow - 1 + End If + Loop Until bLeaveLoop + If RemoveCount > 1 Then + oSheet.Rows.RemoveByIndex(iCurRow, RemoveCount-1) + End If + For i = 1 To iLastLinkRow + oCell = oSheet.GetCellbyPosition(SBDATECOLUMN,iCurRow) + iCellValue = oLinkSheet.GetCellByPosition(0,i).Value + If iCellValue > 0 Then + oCell.SetValue(oLinkSheet.GetCellByPosition(0,i).Value) + Else + oCell.SetValue(StringToDate(oLinkSheet.GetCellByPosition(0,i).String)) + End If + oCell = oSheet.GetCellbyPosition(SBVALUECOLUMN,iCurRow) + oCell.SetValue(oLinkSheet.GetCellByPosition(4,i).Value) + If i < iLastLinkRow Then + iCurRow = iCurRow + 1 + oSheet.Rows.InsertByIndex(iCurRow,1) + End If + Next i + iMaxRow = iCurRow +End Sub + + +Function StringToDate(DateString as String) as Date +Dim ShortMonths(11) +Dim DateList() as String +Dim MaxIndex as Integer +Dim i as Integer + ShortMonths(0) = "Jan" + ShortMonths(1) = "Feb" + ShortMonths(2) = "Mar" + ShortMonths(3) = "Apr" + ShortMonths(4) = "May" + ShortMonths(5) = "Jun" + ShortMonths(6) = "Jul" + ShortMonths(7) = "Aug" + ShortMonths(8) = "Sep" + ShortMonths(9) = "Oct" + ShortMonths(10) = "Nov" + ShortMonths(11) = "Dec" + For i = 0 To 11 + DateString = ReplaceString(DateString,CStr(i+1),ShortMonths(i)) + Next i + DateString = ReplaceString(DateString, ".", "-") + StringToDate = CDate(DateString) +End Function + + +Sub UpdateChart(sName As String) +Dim oSheet As Object +Dim oCell As Object, oCursor As Object +Dim oChartRange As Object +Dim oEmbeddedChart As Object, oCharts As Object +Dim oChart As Object, oDiagram As Object +Dim oYAxis As Object, oXAxis As Object +Dim fMin As Double, fMax As Double +Dim nDateFormat As Long +Dim aPos As Variant +Dim aSize As Variant +Dim oContainerChart as Object +Dim mRangeAddresses(0) as New com.sun.star.table.CellRangeAddress + mRangeAddresses(0).Sheet = GetSheetIndex(oSheets, sNewSheetName) + mRangeAddresses(0).StartColumn = SBDATECOLUMN + mRangeAddresses(0).StartRow = SBSTARTROW-1 + mRangeAddresses(0).EndColumn = SBVALUECOLUMN + mRangeAddresses(0).EndRow = iMaxRow + + oSheet = oDocument.Sheets.getByName(sNewSheetName) + oCharts = oSheet.Charts + + If Not oCharts.hasElements Then + oSheet.GetCellbyPosition(2,2).SetString(sName) + oChartRange = oSheet.getCellRangeByPosition(SBDATECOLUMN,6,5,SBSTARTROW-3) + aPos = oChartRange.Position + aSize = oChartRange.Size + + Dim oRectangleShape As New com.sun.star.awt.Rectangle + oRectangleShape.X = aPos.X + oRectangleShape.Y = aPos.Y + oRectangleShape.Width = aSize.Width + oRectangleShape.Height = aSize.Height + oCharts.addNewByName(sName, oRectangleShape, mRangeAddresses(), True, False) + oContainerChart = oCharts.getByName(sName) + oChart = oContainerChart.EmbeddedObject + oChart.Title.String = "" + oChart.HasLegend = False + oChart.diagram = oChart.createInstance("com.sun.star.chart.XYDiagram") + oDiagram = oChart.Diagram + oDiagram.DataRowSource = com.sun.star.chart.ChartDataRowSource.COLUMNS + oChart.Area.LineStyle = com.sun.star.drawing.LineStyle.SOLID + oXAxis = oDiagram.XAxis + oXAxis.TextBreak = False + nDateFormat = oXAxis.NumberFormats.getStandardFormat(com.sun.star.util.NumberFormat.DATE, oDocLocale) + + oYAxis = oDiagram.getYAxis() + oYAxis.AutoOrigin = True + Else + oChart = oCharts(0) + oChart.Ranges = mRangeAddresses() + oChart.HasRowHeaders = False + oEmbeddedChart = oChart.EmbeddedObject + oDiagram = oEmbeddedChart.Diagram + oXAxis = oDiagram.XAxis + End If + oXAxis.AutoStepMain = False + oXAxis.AutoStepHelp = False + oXAxis.StepMain = iStep + oXAxis.StepHelp = iStep + fMin = oSheet.getCellByPosition(SBDATECOLUMN,SBSTARTROW).Value + fMax = oSheet.getCellByPosition(SBDATECOLUMN,iMaxRow).Value + oXAxis.Min = fMin + oXAxis.Max = fMax + oXAxis.AutoMin = False + oXAxis.AutoMax = False +End Sub + + +Sub CalculateChartafterSplit(SheetName, NewNumber, OldNumber, NoteText, SplitDate) +Dim oSheet as Object +Dim i as Integer +Dim oValueCell as Object +Dim oDateCell as Object +Dim bLeaveLoop as Boolean + If oSheets.HasbyName(SheetName) Then + oSheet = oSheets.GetbyName(SheetName) + i = 0 + bLeaveLoop = False + Do + oValueCell = oSheet.GetCellbyPosition(SBVALUECOLUMN, SBSTARTROW + i) + If oValueCell.CellStyle = CurrCellStyle Then + SplitCellValue(oSheet, OldNumber, NewNumber, SBVALUECOLUMN, SBSTARTROW + i, "") + i = i + 1 + Else + bLeaveLoop = True + End If + Loop Until bLeaveLoop + oDateCell = oSheet.GetCellbyPosition(SBDATECOLUMN, SBSTARTROW + i-1) + oDateCell.Annotation.SetString(NoteText) + End If +End Sub + diff --git a/wizards/source/depot/Lang_de.xba b/wizards/source/depot/Lang_de.xba new file mode 100644 index 000000000..a8b4c55ca --- /dev/null +++ b/wizards/source/depot/Lang_de.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadGermanLanguage() + + sProductname = GetProductname + sOK = "~OK" + sCancel = "Abbrechen" + sColumnHeader = "Spaltenkopf" + sInsertStockName = "Bitte fügen Sie zunächst einige Aktien in Ihr Depot ein!" + sTitle = "<PRODUCTNAME>: Aktienverwaltung" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "Eingabefehler" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "Bitte geben Sie eine Stückzahl größer als 0 ein" + sMsgNoDividend = "Bitte geben Sie eine Dividende je Stück oder eine Gesamtdividende ein" + sMsgNoExchangeRate = "Bitte geben Sie eine korrekte Umtauschrate ein (alte Aktien -> neue Aktien)." + sMsgNoValidExchangeDate = "Bitte geben Sie ein gültiges Datum für den Aktiensplitt ein." + sMsgWrongExchangeDate = "Splitt nicht möglich, da bereits Transaktionen nach dem Splitt-Datum existieren." + sMsgSellTooMuch = "So viele Aktien können Sie nicht verkaufen. Maximum: " + sMsgConfirm = "Bestätigung erforderlich" + sMsgFreeStock = "Beabsichtigen Sie die Eingabe von Gratisaktien?" + sMsgTotalLoss = "Beabsichtigen Sie die Eingabe eines Totalverlustes?" + sMsgAuthorization = "Sicherheitsabfrage" + sMsgDeleteAll = "Wollen Sie alle Bewegungen löschen und die Depotübersicht rücksetzen?" + cSplit = "Aktiensplitt am " + sHistory = "Historie" + TransactTitle(1) = "Aktien verkaufen" + TransactTitle(2) = "Aktien kaufen" + StockRatesTitle(1) = "Dividendenzahlung" + StockRatesTitle(2) = "Aktiensplitt" + StockRatesTitle(3) = sHistory + sDepotCurrency = "Depotwährung" + sStockName = "Aktienname" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "Ergebnis Datum" + CurrCellStyle = "Ergebnis Euro mit Dezimalen" + sStartDate = "Startdatum:" + sEndDate = "Enddatum:" + sStartUpWelcome = "Diese Vorlage ermöglicht Ihnen eine effiziente Verwaltung Ihres Aktiendepots" + sStartUpChooseMarket = "Wählen Sie zunächst Ihre Referenz-Währung und damit den Börsenplatz für das Internet Update aus!" + sStartUpHint = "Leider steht Ihnen die <History>- Funktion nur für den amerikanischen Markt zur Verfügung!" + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "ohne Internet Update" + sMarketPlace = "Börsenplatz:" + sNoInternetDataAvailable = "Internet-Kurse konnten nicht empfangen werden!" + sCheckInternetSettings = "Mögliche Ursachen sind: <BR> Ihre Internet Einstellungen müssen überprüft werden.<BR> Sie haben eine falsche Kennung (z.B. Symbol, WKN) für die Aktie eingegeben." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "Das Enddatum muss vor dem heutigen Tag liegen!" + sMsgStartDatebeforeEndDate = "Das Startdatum muss vor dem Enddatum liegen!" + + sMarket(0,0) = "Amerikanischer Dollar" + sMarket(0,1) = "$" + sMarket(0,2) = "New York" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "Symbol" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "Euro" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "Frankfurt" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "WKN" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "Englisches Pfund" + sMarket(2,1) = "£" + sMarket(2,2) = "London" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "Symbol" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "Japanischer Yen" + sMarket(3,1) = "¥" + sMarket(3,2) = "Tokyo" + sMarket(3,3) = "" + sMarket(3,5) = "Code" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "Hongkong Dollar" + sMarket(4,1) = "HK$" + sMarket(4,2) = "Hongkong" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>.HK&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "Nummer" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "Australischer Dollar" + sMarket(5,1) = "$" + sMarket(5,2) = "Sydney" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "Symbol" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "Menge" + .lblRate.Label = "Kurs" + .lblDate.Label = "Transaktionsdatum" + .hlnCommission.Label = "Sonstige Ausgaben" + .lblCommission.Label = "Provision" + .lblMinimum.Label = "Mindestprovision" + .lblFix.Label = "Festbetrag/Spesen" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "Dividende/Aktie" + .optTotal.Label = "Dividende gesamt" + .lblDividend.Label = "Betrag" + .lblExchangeRate.Label = "Umtauschrate (alt->neu)" + .lblColon.Label = ":" + .lblDate.Label = "Umtauschdatum:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~Täglich" + .optWeekly.Label = "~Wöchentlich" + .hlnInterval.Label = "Zeitraum" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_en.xba b/wizards/source/depot/Lang_en.xba new file mode 100644 index 000000000..b97efb156 --- /dev/null +++ b/wizards/source/depot/Lang_en.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadEnglishLanguage() + + sProductname = GetProductname + sOK = "~OK" + sCancel = "Cancel" + sColumnHeader = "Column Header" + sInsertStockName = "Please enter shares in your portfolio." + sTitle = "<PRODUCTNAME>: Stocks Manager" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "Input Error" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "Please enter a quantity larger than 0" + sMsgNoDividend = "Please enter the dividend per share or the total dividend" + sMsgNoExchangeRate = "Please enter the correct exchange rate (old shares -> new shares)" + sMsgNoValidExchangeDate = "Please enter a valid date for the split." + sMsgWrongExchangeDate = "Splitting not possible, as transactions already exist after the split date." + sMsgSellTooMuch = "You cannot sell that many shares. Maximum: " + sMsgConfirm = "Confirmation Required" + sMsgFreeStock = "Do you intend to enter free shares?" + sMsgTotalLoss = "Do you intend to enter a total loss?" + sMsgAuthorization = "Security Query" + sMsgDeleteAll = "Do you want to delete all movements and reset the portfolio overview?" + cSplit = "Stock split on " + sHistory = "History" + TransactTitle(1) = "StarOffice Stocks Manager: Selling Shares" + TransactTitle(2) = "StarOffice Stocks Manager: Buying Shares" + StockRatesTitle(1) = "StarOffice Stocks Manager: Dividend Payment" + StockRatesTitle(2) = "Stock Split" + StockRatesTitle(3) = sHistory + sDepotCurrency = "Portfolio Currency" + sStockName = "Name of Stock" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "Result Date" + CurrCellStyle = "1" + sStartDate = "Start date:" + sEndDate = "End date:" + sStartUpWelcome = "This template enables you to manage your stock portfolio efficiently." + sStartUpChooseMarket = "First, select your reference currency and thus the stock exchange for the Internet update." + sStartUpHint = "Unfortunately, the only <History> function available to you is that for the American market." + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "without Internet update" + sMarketPlace = "Stock exchange:" + sNoInternetDataAvailable = "No prices could be received from the Internet!" + sCheckInternetSettings = "Possible causes could be: <BR>Your Internet settings have to be modified. <BR>The Symbol (e.g. Code, Ticker Symbol) entered for the stock was incorrect." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "The end date has to be before today's date." + sMsgStartDatebeforeEndDate = "The start date has to be before the end date." + + sMarket(0,0) = "American Dollar" + sMarket(0,1) = "$" + sMarket(0,2) = "New York" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "Symbol" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "Euro" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "Frankfurt" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "Ticker Symbol" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "British Pound" + sMarket(2,1) = "£" + sMarket(2,2) = "London" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "Symbol" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "Japanese Yen" + sMarket(3,1) = "¥" + sMarket(3,2) = "Tokyo" + sMarket(3,3) = "" + sMarket(3,5) = "Code" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "Hong Kong Dollar" + sMarket(4,1) = "HK$" + sMarket(4,2) = "Hong Kong" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "Number" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "Australian Dollar" + sMarket(5,1) = "$" + sMarket(5,2) = "Sydney" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "Symbol" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "Quantity" + .lblRate.Label = "Price" + .lblDate.Label = "Transaction Date" + .hlnCommission.Label = "Other expenditures" + .lblCommission.Label = "Commission" + .lblMinimum.Label = "Min. Commission" + .lblFix.Label = "Fixed Costs/Charges" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "Dividends/Stocks" + .optTotal.Label = "Total Dividends" + .lblDividend.Label = "Amount" + .lblExchangeRate.Label = "Exchange Rate (old->new)" + .lblColon.Label = ":" + .lblDate.Label = "Exchange Date:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~Daily" + .optWeekly.Label = "~Weekly" + .hlnInterval.Label = "Time period" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_es.xba b/wizards/source/depot/Lang_es.xba new file mode 100644 index 000000000..b6bf01c43 --- /dev/null +++ b/wizards/source/depot/Lang_es.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadSpanishLanguage() + + sProductname = GetProductname + sOK = "~Aceptar" + sCancel = "Cancelar" + sColumnHeader = "Título de columna" + sInsertStockName = "Introduzca primero algunas acciones en su depósito." + sTitle = "<PRODUCTNAME>: Administración de acciones" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "Error de entrada" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "Indique una cantidad mayor que 0" + sMsgNoDividend = "Indique un dividendo por unidad o un dividendo total" + sMsgNoExchangeRate = "Indique aquí un cambio correcto (acción vieja -> nueva acción)" + sMsgNoValidExchangeDate = "Indique una fecha correcta para el fraccionamiento de la acción." + sMsgWrongExchangeDate = "El fraccionamiento no es posible porque existen transacciones después de la fecha de fraccionamiento." + sMsgSellTooMuch = "No puede vender tantas acciones. Como máximo: " + sMsgConfirm = "Confirmación necesaria" + sMsgFreeStock = "¿Tiene previsto considerar acciones gratis?" + sMsgTotalLoss = "¿Tiene previsto introducir una pérdida total?" + sMsgAuthorization = "Pregunta de seguridad" + sMsgDeleteAll = "¿Desea borrar todos los movimientos y reiniciar el balance de depósito?" + cSplit = "Fraccionamiento el " + sHistory = "Historia" + TransactTitle(1) = "Vender acciones" + TransactTitle(2) = "Comprar acciones" + StockRatesTitle(1) = "Pago de dividendos" + StockRatesTitle(2) = "Fraccionamiento" + StockRatesTitle(3) = sHistory + sDepotCurrency = "Moneda del depósito" + sStockName = "Nombre de la acción" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "Resultado Fecha" + CurrCellStyle = "1" + sStartDate = "Fecha de inicio:" + sEndDate = "Fecha final:" + sStartUpWelcome = "Esta plantilla le permite administrar eficientemente su depósito de acciones" + sStartUpChooseMarket = "Seleccione primero la moneda de referencia y la plaza bursátil para la actualización a través de Internet." + sStartUpHint = "La función <History> está disponible únicamente para el mercado americano." + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "Sin actualización por Internet" + sMarketPlace = "Plaza bursátil:" + sNoInternetDataAvailable = "No se pudieron recibir las cotizaciones por Internet." + sCheckInternetSettings = "Causas posibles: <BR> Debe comprobar la configuración de Internet.<BR> Ha indicado un código incorrecto (p.ej. número, símbolo, etc.) para la acción." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "La fecha final debe ser anterior a la fecha de hoy." + sMsgStartDatebeforeEndDate = "La fecha inicial debe ser anterior a la fecha final." + + sMarket(0,0) = "Dólar estadounidense" + sMarket(0,1) = "$" + sMarket(0,2) = "Nueva York" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "Símbolo" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "Euro" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "Frankfurt" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "Código" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "Libra esterlina" + sMarket(2,1) = "£" + sMarket(2,2) = "Londres" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "Símbolo" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "Yen japonés" + sMarket(3,1) = "¥" + sMarket(3,2) = "Tokio" + sMarket(3,3) = "" + sMarket(3,5) = "Código" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "Dólar hongkonés" + sMarket(4,1) = "HK$" + sMarket(4,2) = "Hong Kong" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>.HK&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "Número" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "Dólar australiano" + sMarket(5,1) = "$" + sMarket(5,2) = "Sidney" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "Símbolo" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "Cantidad" + .lblRate.Label = "Cotización" + .lblDate.Label = "Fecha de operación" + .hlnCommission.Label = "Otros gastos" + .lblCommission.Label = "Provisión" + .lblMinimum.Label = "Provisión mínima" + .lblFix.Label = "Cantidad fija/comisión" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "Dividendos/Acción" + .optTotal.Label = "Dividendos totales" + .lblDividend.Label = "Importe" + .lblExchangeRate.Label = "Cambio (vieja->nueva)" + .lblColon.Label = ":" + .lblDate.Label = "Fecha de cambio:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~Diario" + .optWeekly.Label = "~Semanal" + .hlnInterval.Label = "Periodo" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_fr.xba b/wizards/source/depot/Lang_fr.xba new file mode 100644 index 000000000..27f9a685c --- /dev/null +++ b/wizards/source/depot/Lang_fr.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadFrenchLanguage() + + sProductname = GetProductname + sOK = "~OK" + sCancel = "Annuler" + sColumnHeader = "En-tête de colonne" + sInsertStockName = "Saisissez quelques actions dans votre portefeuille !" + sTitle = "<PRODUCTNAME> : Gestion d'actions" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "Erreur de saisie" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "Saisissez une quantité supérieure à 0 !" + sMsgNoDividend = "Vous devez saisir le montant des dividendes perçus (soit les dividendes par action, soit la somme totale perçue)." + sMsgNoExchangeRate = "Saisissez un taux correct de conversion (anciennes actions -> nouvelles actions)." + sMsgNoValidExchangeDate = "Saisissez une date correcte pour le split d'action." + sMsgWrongExchangeDate = "Split impossible car il y a déjà eu des transactions après la date du split !" + sMsgSellTooMuch = "Impossible de vendre autant d'actions ! Maximum : " + sMsgConfirm = "Confirmation required" + sMsgFreeStock = "S'agit-il d'actions gratuites ?" + sMsgTotalLoss = "Prévoyez-vous une perte totale ?" + sMsgAuthorization = "Requête de sécurité" + sMsgDeleteAll = "Voulez-vous supprimer tous les mouvements et remettre le portefeuille d'actions à zéro ?" + cSplit = "Split d'action le " + sHistory = "Historique" + TransactTitle(1) = "Vente d'actions" + TransactTitle(2) = "Achat d'actions" + StockRatesTitle(1) = "Versement des dividendes" + StockRatesTitle(2) = "Split d'action" + StockRatesTitle(3) = sHistory + sDepotCurrency = "Monnaie du portefeuille" + sStockName = "Nom de l'action" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "Résultat date" + CurrCellStyle = "1" + sStartDate = "Date de début :" + sEndDate = "Date de fin :" + sStartUpWelcome = "Utilisez ce modèle pour une gestion efficiente de votre portefeuille d'actions !" + sStartUpChooseMarket = "Commencez par choisir une monnaie de référence et ainsi la place boursière pour la mise à jour Internet !" + sStartUpHint = "La fonction <History> n'est cependant disponible que pour le marché américain." + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "Sans mise à jour Internet" + sMarketPlace = "Place boursière :" + sNoInternetDataAvailable = "Réception des cours Internet impossible !" + sCheckInternetSettings = "Causes possibles : <BR> Problème de paramétrage Internet : vérifiez les paramètres !<BR> Vous avez saisi un identificateur (par ex. symbole ou code) incorrect pour l'action." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "La date spécifiée pour la fin doit précéder celle de ce jour !" + sMsgStartDatebeforeEndDate = "La date spécifiée pour le début doit succéder à celle de ce jour !" + + sMarket(0,0) = "Dollar Américain" + sMarket(0,1) = "$" + sMarket(0,2) = "New York" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "Symbole" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "Euro" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "Francfort" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "Code" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "Livre Sterling" + sMarket(2,1) = "£" + sMarket(2,2) = "Londres" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "Symbole" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "Yen Japonais" + sMarket(3,1) = "¥" + sMarket(3,2) = "Tokyo" + sMarket(3,3) = "" + sMarket(3,5) = "Code" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "Dollar de Hong Kong" + sMarket(4,1) = "HK$" + sMarket(4,2) = "Hong Kong" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "Numéro" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "Dollar Australien" + sMarket(5,1) = "$" + sMarket(5,2) = "Sydney" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "Symbole" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "Quantité" + .lblRate.Label = "Cours" + .lblDate.Label = "Date de transaction" + .hlnCommission.Label = "Dépenses diverses" + .lblCommission.Label = "Commission" + .lblMinimum.Label = "Commission minimale" + .lblFix.Label = "Montant fixe/frais" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "Dividende/action" + .optTotal.Label = "Dividende total" + .lblDividend.Label = "Montant" + .lblExchangeRate.Label = "Taux de conversion (ancien->nouveau)" + .lblColon.Label = ":" + .lblDate.Label = "Date de la conversion:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~Quotidien" + .optWeekly.Label = "~Hebdomadaire" + .hlnInterval.Label = "Période" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + diff --git a/wizards/source/depot/Lang_it.xba b/wizards/source/depot/Lang_it.xba new file mode 100644 index 000000000..a8d21bf25 --- /dev/null +++ b/wizards/source/depot/Lang_it.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadItalianLanguage() + + sProductname = GetProductname + sOK = "~OK" + sCancel = "Annulla" + sColumnHeader = "Intestazione colonna" + sInsertStockName = "Inserite un nome di azioni" + sTitle = "<PRODUCTNAME>: Gestione delle azioni" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "Errore dati immessi" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "Inserite il numero delle azioni" + sMsgNoDividend = "Inserite un dividendo a unità oppure un dividendo totale" + sMsgNoExchangeRate = "Indicate un corretto tasso di cambio (vecchie azioni -> nuove azioni)." + sMsgNoValidExchangeDate = "Indicate la data di frazionamento delle azioni." + sMsgWrongExchangeDate = "Il frazionamento non è possibile perché sono ancora in atto transazioni dopo la data indicata." + sMsgSellTooMuch = "Non potete vendere così tante azioni. Massimo: " + sMsgConfirm = "È necessaria una conferma" + sMsgFreeStock = "Confermate la digitazione di azioni gratuite?" + sMsgTotalLoss = "Confermate la digitazione di perdita totale?" + sMsgAuthorization = "Domanda di sicurezza" + sMsgDeleteAll = "Eliminare tutti i movimenti e ripristinare la panoramica dei depositi?" + cSplit = "Frazionamento delle azioni il: " + sHistory = "Cronologia" + TransactTitle(1) = "Vendita di azioni" + TransactTitle(2) = "Acquisto di azioni" + StockRatesTitle(1) = "Pagamento dei dividendi" + StockRatesTitle(2) = "Frazionamento azioni" + StockRatesTitle(3) = sHistory + sDepotCurrency = "Valuta deposito" + sStockName = "Nome delle azioni" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "Risultato data" + CurrCellStyle = "1" + sStartDate = "Data d'inizio:" + sEndDate = "Data finale:" + sStartUpWelcome = "Questo modello vi permette una gestione efficace delle vostre azioni." + sStartUpChooseMarket = "Selezionate la valuta di riferimento e la Borsa per il collegamento Internet." + sStartUpHint = "La funzione <History> è disponibile solo per il mercato americano." + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "Senza aggiornamento Internet" + sMarketPlace = "Borsa:" + sNoInternetDataAvailable = "Impossibile ricevere le quotazioni Internet" + sCheckInternetSettings = "Possibili cause: <BR> le impostazioni Internet devono essere modificate.<BR> Avete indicato un indice (ad es. simbolo o codice) errato per le azioni." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "La data finale dev'essere anteriore alla data odierna." + sMsgStartDatebeforeEndDate = "La data d'inizio deve precedere la data finale." + + sMarket(0,0) = "Dollaro USA" + sMarket(0,1) = "$" + sMarket(0,2) = "New York" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "Simbolo" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "Euro" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "Francoforte" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "Numero identificazione titoli" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "Sterlina inglese" + sMarket(2,1) = "£" + sMarket(2,2) = "Londra" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "Simbolo" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "Yen" + sMarket(3,1) = "¥" + sMarket(3,2) = "Tokyo" + sMarket(3,3) = "" + sMarket(3,5) = "Codice" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "Dollaro Hong Kong" + sMarket(4,1) = "HK$" + sMarket(4,2) = "Hong Kong" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "Numero" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "Dollaro australiano" + sMarket(5,1) = "$" + sMarket(5,2) = "Sydney" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "Simbolo" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "Quantità" + .lblRate.Label = "Quotazione" + .lblDate.Label = "Data della transazione" + .hlnCommission.Label = "Spese extra" + .lblCommission.Label = "Commissioni" + .lblMinimum.Label = "Commissione minima" + .lblFix.Label = "Importo fisso/Spese" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "Dividendo/Azione" + .optTotal.Label = "Dividendo totale" + .lblDividend.Label = "Importo" + .lblExchangeRate.Label = "Tasso di cambio (vecchio->nuovo)" + .lblColon.Label = ":" + .lblDate.Label = "Data di cambio:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~Giornaliero" + .optWeekly.Label = "~Settimanale" + .hlnInterval.Label = "Durata" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + diff --git a/wizards/source/depot/Lang_ja.xba b/wizards/source/depot/Lang_ja.xba new file mode 100644 index 000000000..114a0bf08 --- /dev/null +++ b/wizards/source/depot/Lang_ja.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadJapaneseLanguage() + + sProductname = GetProductname + sOK = "~OK" + sCancel = "キャンセル" + sColumnHeader = "列番号" + sInsertStockName = "最初に株の銘柄を入力してください。" + sTitle = "<PRODUCTNAME>: 株管理" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "入力フィールド" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "0 より大きな額を入力してください。" + sMsgNoDividend = "１株当たりの配当金額または総配当金額を入力してください。" + sMsgNoExchangeRate = "交換比率（旧株->新株）を入力してください。" + sMsgNoValidExchangeDate = "株式分割日を入力してください。" + sMsgWrongExchangeDate = "分割日以降に取引がすでに存在するので、分割できません。" + sMsgSellTooMuch = "売却できる株式数を超えています。最大値: " + sMsgConfirm = "ご確認ください" + sMsgFreeStock = "無料株式を入力しますか?" + sMsgTotalLoss = "全損の入力を行いますか?" + sMsgAuthorization = "確認ダイアログ" + sMsgDeleteAll = "すべての移動を取り消し、ポートフォリオの概要をリセットしますか?" + cSplit = "株式分割日 " + sHistory = "履歴" + TransactTitle(1) = "株を買う" + TransactTitle(2) = "株を買う" + StockRatesTitle(1) = "配当額" + StockRatesTitle(2) = "株式分割" + StockRatesTitle(3) = sHistory + sDepotCurrency = "ポートフォリオの通貨" + sStockName = "株式名" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "結果（日付）" + CurrCellStyle = "1" + sStartDate = "開始日:" + sEndDate = "終了日:" + sStartUpWelcome = "このテンプレートを使えば、株式のポートフォリオをより効率的に管理できます。" + sStartUpChooseMarket = "まず、インターネットにより情報を更新する基準通貨と、対応する証券取引所を選択します。" + sStartUpHint = "残念ながら、<History> 機能を使用できるのは米国市場に限られています。" + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "インターネットによる情報の更新を行いません" + sMarketPlace = "証券取引所:" + sNoInternetDataAvailable = "インターネットから株価情報を受信できない場合があります!" + sCheckInternetSettings = "考えられる原因は次のとおりです。<BR>インターネット設定の変更が必要です。<BR>入力した株式のが間違っています。" + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "終了日は、今日の日付より前であることが必要です。" + sMsgStartDatebeforeEndDate = "開始日は、終了日より前であることが必要です。" + + sMarket(0,0) = "米ドル" + sMarket(0,1) = "$" + sMarket(0,2) = "ニューヨーク" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "シンボル" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "ユーロ" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "フランクフルト" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "銘柄コード" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "英ポンド" + sMarket(2,1) = "£" + sMarket(2,2) = "ロンドン" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "シンボル" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "日本円" + sMarket(3,1) = "¥" + sMarket(3,2) = "東京" + sMarket(3,3) = "" + sMarket(3,5) = "コード" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "香港ドル" + sMarket(4,1) = "HK$" + sMarket(4,2) = "香港" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>.HK&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "番号" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "オーストリア・ドル" + sMarket(5,1) = "$" + sMarket(5,2) = "シドニー" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "シンボル" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "株数" + .lblRate.Label = "価格" + .lblDate.Label = "取引日" + .hlnCommission.Label = "その他の経費n" + .lblCommission.Label = "手数料" + .lblMinimum.Label = "最低手数料" + .lblFix.Label = "固定費/諸経費" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "配当金/株式数" + .optTotal.Label = "配当金の総額" + .lblDividend.Label = "金額" + .lblExchangeRate.Label = "交換比率（旧株->新株）" + .lblColon.Label = ":" + .lblDate.Label = "交換日:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~毎日" + .optWeekly.Label = "~毎週" + .hlnInterval.Label = "期間" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_ko.xba b/wizards/source/depot/Lang_ko.xba new file mode 100644 index 000000000..fcc3224e1 --- /dev/null +++ b/wizards/source/depot/Lang_ko.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadKoreanLanguage() + + sProductname = GetProductname + sOK = "~확인" + sCancel = "취소" + sColumnHeader = "열 머리글" + sInsertStockName = "주식 종목을 삽입해주십시오." + sTitle = "<PRODUCTNAME>: 주식 매수" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "입력 오류" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "0 이하의 매수를 입력해주십시오." + sMsgNoDividend = "한 주당 배당분 또는 총배당분을 입력해주십시오." + sMsgNoExchangeRate = "정확한 환율을 입력해주십시오 (구주를 신주로 소급 시)." + sMsgNoValidExchangeDate = "유효한 배당 결제일을 입력해주십시오." + sMsgWrongExchangeDate = "배당 기준일이 경과하여 배당할 수 없습니다." + sMsgSellTooMuch = "이렇게 많은 주식을 팔 수 없습니다. 최대 매도수: " + sMsgConfirm = "확인 필요" + sMsgFreeStock = "공짜 주식을 입력하시겠습니까?" + sMsgTotalLoss = "주가 폭락세를 입력하시겠습니까?" + sMsgAuthorization = "안정성 조회" + sMsgDeleteAll = "모든 주가 움직임을 삭제하고 계좌 현황을 원래대로 하시겠습니까?" + cSplit = "주식 배당일 " + sHistory = "내역" + TransactTitle(1) = "주식 관리: 주식 매도" + TransactTitle(2) = "주식 관리: 주식 매수" + StockRatesTitle(1) = "주식 관리: 배당금 지불" + StockRatesTitle(2) = "주식 관리: 주식 배분" + StockRatesTitle(3) = sHistory + sDepotCurrency = "주식 계좌 통화" + sStockName = "주식 종목명" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "결과, 날짜" + CurrCellStyle = "1" + sStartDate = "매매일:" + sEndDate = "만기일:" + sStartUpWelcome = "이 템플릿을 사용하여 주식 투자 관리를 효율적으로 할 수 있습니다." + sStartUpChooseMarket = "인터넷 업데이트를 위해 우선 관련 통화와 증권 장소를 선택하십시오." + sStartUpHint = "<내역> 기능은 미국 시장용으로만 사용할 수 있습니다." + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "인터넷 업데이트 없음" + sMarketPlace = "증권 장소:" + sNoInternetDataAvailable = "인터넷 시세는 받을 수 없었습니다." + sCheckInternetSettings = "원인: <BR> 인터넷 설정을 점검해야만 합니다.<BR> 옳지 않은 암호<예를 들어 잘못된 문자 또는 종목 코드>를 입력했습니다." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "만기일은 오늘 날짜 전에 기입되어야 합니다." + sMsgStartDatebeforeEndDate = "매매일은 만기일 전에 기입되어야 합니다." + + sMarket(0,0) = "미국 달러" + sMarket(0,1) = "$" + sMarket(0,2) = "뉴욕" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "기호" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "유로" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "프랑크푸르트" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "WKN" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "영국 파운드" + sMarket(2,1) = "£" + sMarket(2,2) = "런던" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "기호" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "엔화" + sMarket(3,1) = "¥" + sMarket(3,2) = "도쿄" + sMarket(3,3) = "" + sMarket(3,5) = "코드" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "홍콩 달러" + sMarket(4,1) = "HK$" + sMarket(4,2) = "홍콩" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>.HK&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "번호" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "호주 달러" + sMarket(5,1) = "$" + sMarket(5,2) = "시드니" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "기호" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "수량" + .lblRate.Label = "시세" + .lblDate.Label = "배당 결산일" + .hlnCommission.Label = "기타 지출" + .lblCommission.Label = "수수료" + .lblMinimum.Label = "최저 수수료" + .lblFix.Label = "약정 금액/기타 경비" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "배당분/주" + .optTotal.Label = "배당분 합계" + .lblDividend.Label = "금액" + .lblExchangeRate.Label = "환율(구주->신주)" + .lblColon.Label = ":" + .lblDate.Label = "환율일자" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~매일" + .optWeekly.Label = "~매주" + .hlnInterval.Label = "기간" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_sv.xba b/wizards/source/depot/Lang_sv.xba new file mode 100644 index 000000000..cbe67e1c2 --- /dev/null +++ b/wizards/source/depot/Lang_sv.xba @@ -0,0 +1,174 @@ + + + +Option Explicit + +Sub LoadSwedishLanguage() + sProductname = GetProductname + sOK = "~OK" + sCancel = "Avbryt" + sColumnHeader = "Kolumnhuvud" + sInsertStockName = "Infoga först några aktier i Din portfölj!" + sTitle = "<PRODUCTNAME>: Aktieförvaltning" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "Inmatningsfel" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "Var vänlig och mata in ett större antal än 0" + sMsgNoDividend = "Var vänlig och mata in utdelning per styck eller den totala utdelningen" + sMsgNoExchangeRate = "Var vänlig och mata in en korrekt omräkningskurs (gamla aktier -> nya aktier)." + sMsgNoValidExchangeDate = "Var vänlig och mata in ett giltigt datum för aktiesplitten." + sMsgWrongExchangeDate = "Split är inte möjlig eftersom det redan finns transaktioner efter splitdatum." + sMsgSellTooMuch = "Så många aktier kan Du inte sälja. Maximum: " + sMsgConfirm = "Bekräftelse krävs" + sMsgFreeStock = "Avser Du att mata in gratisaktier?" + sMsgTotalLoss = "Avser Du att mata in en totalförlust?" + sMsgAuthorization = "Säkerhetskontroll" + sMsgDeleteAll = "Vill Du ta bort alla rörelser och återställa portföljöversikten?" + cSplit = "Aktiesplit den " + sHistory = "Historik" + TransactTitle(1) = "Sälja aktier" + TransactTitle(2) = "Köpa aktier" + StockRatesTitle(1) = "Aktieutdelning" + StockRatesTitle(2) = "Aktiesplit" + StockRatesTitle(3) = sHistory + sDepotCurrency = "Portföljvaluta" + sStockName = "Aktienamn" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "Resultat datum" + CurrCellStyle = "1" + sStartDate = "Startdatum:" + sEndDate = "Slutdatum:" + sStartUpWelcome = "Med hjälp av den här mallen kan Du förvalta Din aktieportfölj effektivt" + sStartUpChooseMarket = "Välj först Din referensvaluta och därigenom börs för Internet-uppdateringen!" + sStartUpHint = "Tyvärr är <History>-funktionen bara tillgänglig för den amerikanska marknaden!" + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "utan Internet-uppdatering" + sMarketPlace = "Börs:" + sNoInternetDataAvailable = "Det gick inte att ta emot Internet-kurser!" + sCheckInternetSettings = "Detta kan bero på att: <BR> Dina Internet-inställningar måste ändras.<BR> Du har angivit ett felaktigt ID (t.ex. symbol, värdepappersnr.) för aktien." + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "Slutdatum måste ligga före idag!" + sMsgStartDatebeforeEndDate = "Startdatum måste ligga före slutdatum!" + + sMarket(0,0) = "Amerikansk dollar" + sMarket(0,1) = "$" + sMarket(0,2) = "New York" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "Symbol" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "Euro" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "Frankfurt" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "Värdepappersnr" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "Engelskt pund" + sMarket(2,1) = "£" + sMarket(2,2) = "London" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "Symbol" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "Japansk yen" + sMarket(3,1) = "¥" + sMarket(3,2) = "Tokyo" + sMarket(3,3) = "" + sMarket(3,5) = "Kod" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "Hongkongdollar" + sMarket(4,1) = "HK$" + sMarket(4,2) = "Hongkong" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "Nummer" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "Australisk dollar" + sMarket(5,1) = "$" + sMarket(5,2) = "Sydney" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "Symbol" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "Antal" + .lblRate.Label = "Kurs" + .lblDate.Label = "Transaktionsdatum" + .hlnCommission.Label = "Övriga utgifter" + .lblCommission.Label = "Provision" + .lblMinimum.Label = "Minimiprovision" + .lblFix.Label = "Fast belopp/omkostnader" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "Utdelning per aktie" + .optTotal.Label = "Utdelning totalt" + .lblDividend.Label = "Belopp" + .lblExchangeRate.Label = "Omräkningskurs (gammal->ny)" + .lblColon.Label = ":" + .lblDate.Label = "Omräkningsdatum:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "~Dagligen" + .optWeekly.Label = "~Varje vecka" + .hlnInterval.Label = "Period" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_tw.xba b/wizards/source/depot/Lang_tw.xba new file mode 100644 index 000000000..a4df8c1b6 --- /dev/null +++ b/wizards/source/depot/Lang_tw.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadChineseTradLanguage() + + sProductname = GetProductname + sOK = "確定" + sCancel = "取消" + sColumnHeader = "欄標簽" + sInsertStockName = "請先填入股票名稱!" + sTitle = "<PRODUCTNAME>: 股票管理" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "輸入無效" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "請輸入大於0的交易股數" + sMsgNoDividend = "請輸入每股股息金額或股息總額" + sMsgNoExchangeRate = "請鍵入正確的換算比率(舊股票 -> 新股票)。" + sMsgNoValidExchangeDate = "請輸入股票分割的日期。" + sMsgWrongExchangeDate = "無法分割股票，因為分割日期之後已經買進或賣出股票。" + sMsgSellTooMuch = "最多能出售的股票數： " + sMsgConfirm = "需要确認" + sMsgFreeStock = "需要輸入一個贈送的股票？" + sMsgTotalLoss = "要輸入一個全部損失的股票？" + sMsgAuthorization = "安全詢問" + sMsgDeleteAll = "您要刪除所有的交易資料，重新建立一個股票一覽表？" + cSplit = "股票分割的日期 " + sHistory = "紀錄" + TransactTitle(1) = "出售股票" + TransactTitle(2) = "購買股票" + StockRatesTitle(1) = "支付股息" + StockRatesTitle(2) = "股票分割" + StockRatesTitle(3) = sHistory + sDepotCurrency = "股票的貨幣" + sStockName = "股票名稱" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "結果 日期" + CurrCellStyle = "1" + sStartDate = "交割日期：" + sEndDate = "到期日期：" + sStartUpWelcome = "這個樣式用於高效能地管理股票交易。" + sStartUpChooseMarket = "請先選一個參照的貨幣和一個可直接從 Internet 更新資料的贈券交易所。" + sStartUpHint = "很遺憾，<History>-功能僅適用於美國的交易所。" + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "不透過 internet 更新" + sMarketPlace = "證券交易所：" + sNoInternetDataAvailable = "無法接受 Internet 股票價格!" + sCheckInternetSettings = "可能的原因：<BR>Internet 設定不正確，需要重新設定。<BR>輸入了一個錯誤的股票代碼。" + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "到期日期必須是在今日之前！" + sMsgStartDatebeforeEndDate = "交割日期必須是在到期日期之前！" + + sMarket(0,0) = "美元" + sMarket(0,1) = "$" + sMarket(0,2) = "紐約" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "股票符號" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "歐元" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "法蘭克福" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "股代碼" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "英鎊" + sMarket(2,1) = "£" + sMarket(2,2) = "倫敦" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "股票符號" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "日元" + sMarket(3,1) = "¥" + sMarket(3,2) = "東京" + sMarket(3,3) = "" + sMarket(3,5) = "代碼" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "港幣" + sMarket(4,1) = "HK$" + sMarket(4,2) = "香港" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>.HK&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "編號" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "澳元" + sMarket(5,1) = "$" + sMarket(5,2) = "悉尼" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "股票符號" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "數量" + .lblRate.Label = "股票價格" + .lblDate.Label = "交易日期" + .hlnCommission.Label = "其它的支出費用" + .lblCommission.Label = "手續費" + .lblMinimum.Label = "最低手續費" + .lblFix.Label = "固定金額/費用" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "每股股息" + .optTotal.Label = "股息總計" + .lblDividend.Label = "金額" + .lblExchangeRate.Label = "轉換比率(舊股票 -> 新股票)" + .lblColon.Label = ":" + .lblDate.Label = "轉換日期:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "每日" + .optWeekly.Label = "每週" + .hlnInterval.Label = "時間週期" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/Lang_zh.xba b/wizards/source/depot/Lang_zh.xba new file mode 100644 index 000000000..a4dde61b4 --- /dev/null +++ b/wizards/source/depot/Lang_zh.xba @@ -0,0 +1,175 @@ + + + +Option Explicit + +Sub LoadChineseSimpleLanguage() + + sProductname = GetProductname + sOK = "确定" + sCancel = "取消" + sColumnHeader = "列标题" + sInsertStockName = "请首先往您的帐号内输入一些股票名称！" + sTitle = "<PRODUCTNAME>：股票管理" + sTitle = ReplaceString(sTitle, sProductName, "<PRODUCTNAME>") + sMsgError = "输入错误" + sMsgNoName = sInsertStockname + sMsgNoQuantity = "请输入大于0的交易股数" + sMsgNoDividend = "请输入每股的红利金额或红利总额" + sMsgNoExchangeRate = "请输入一个正确的兑换率(旧股-> 新股)。" + sMsgNoValidExchangeDate = "请输入拆股生效日期。" + sMsgWrongExchangeDate = "因为在拆股生效后已经进行了股票交易，所以无法拆股。" + sMsgSellTooMuch = "您最多能出售的股票数为： " + sMsgConfirm = "需要确认" + sMsgFreeStock = "您想要输入赠送股票？" + sMsgTotalLoss = "您想要输入总亏损值？" + sMsgAuthorization = "安全查询" + sMsgDeleteAll = "您要删除所有的交易信息并重新建立股票帐号一览表吗？" + cSplit = "股票拆股日期 " + sHistory = "记录" + TransactTitle(1) = "出售股票" + TransactTitle(2) = "购买股票" + StockRatesTitle(1) = "支付红利" + StockRatesTitle(2) = "股票拆股" + StockRatesTitle(3) = sHistory + sDepotCurrency = "股票交易的货币" + sStockName = "股票名称" + TransactMode = LIFO ' Possible values: "FIFO" and "LIFO" + DateCellStyle = "结果 日期" + CurrCellStyle = "1" + sStartDate = "起始日期：" + sEndDate = "终止日期：" + sStartUpWelcome = "这个样式能够帮助您有效地管理自己的股票帐号" + sStartUpChooseMarket = "请首先选择采用的参考货币以及要直接用国际互联网来更新资料的证券交易所！" + sStartUpHint = "很遗憾，<History>功能仅可供美国市场使用！" + sStartupHint = ReplaceString(sStartUpHint, sHistory, "<History>") + sNoInternetUpdate = "不通过国际互联网更新" + sMarketPlace = "交易所：" + sNoInternetDataAvailable = "无法获得国际互联网上的行情！" + sCheckInternetSettings = "可能的原因是：<BR>您的国际互联网设定不正确，需要重新设定。<BR>输入了一个错误的股票号码。" + sCheckInternetSettings = ReplaceString(sCheckInternetSettings, chr(13), "<BR>") + + sMsgEndDatebeforeNow = "终止日期必须在今天之前！" + sMsgStartDatebeforeEndDate = "起始日期必须在终止日期之前！" + + sMarket(0,0) = "美元" + sMarket(0,1) = "$" + sMarket(0,2) = "纽约" + sMarket(0,3) = "http://finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(0,4) = "http://ichart.finance.yahoo.com/table.csv?" &_ + "s=<StockID>&d=<EndMonth>&e=<EndDay>&f=<Endyear>&g=d&" &_ + "a=<StartMonth>&b=<StartDay>&c=<Startyear>&ignore=.csv" + sMarket(0,5) = "图标" + sMarket(0,6) = "en" + sMarket(0,7) = "US" + sMarket(0,8) = "409" + sMarket(0,9) = "44" + sMarket(0,10) = "1" + + sMarket(1,0) = "欧元" + sMarket(1,1) = chr(8364) + sMarket(1,2) = "法兰克福" + sMarket(1,3) = "http://de.finance.yahoo.com/d/quotes.csv?s=<StockID>.F&f=sl1t1c1ghpv&e=.csv" + sMarket(1,5) = "代码" + sMarket(1,6) = "de;nl;pt;el" + sMarket(1,7) = "DE;NL;PT;GR" + sMarket(1,8) = "407;413;816;408" + sMarket(1,9) = "59/9" + sMarket(1,10) = "1" + + sMarket(2,0) = "英镑" + sMarket(2,1) = "£" + sMarket(2,2) = "伦敦" + sMarket(2,3) = "http://uk.finance.yahoo.com/d/quotes.csv?s=<StockID>.L&m=*&f=sl1t1c1ghov&e=.csv" + sMarket(2,5) = "股票代码" + sMarket(2,6) = "en" + sMarket(2,7) = "GB" + sMarket(2,8) = "809" + sMarket(2,9) = "44" + sMarket(2,10) = "1" + + sMarket(3,0) = "日元" + sMarket(3,1) = "¥" + sMarket(3,2) = "东京" + sMarket(3,3) = "" + sMarket(3,5) = "代码" + sMarket(3,6) = "ja" + sMarket(3,7) = "JP" + sMarket(3,8) = "411" + sMarket(3,9) = "" + sMarket(3,10) = "" + + sMarket(4,0) = "港币" + sMarket(4,1) = "HK$" + sMarket(4,2) = "香港" + sMarket(4,3) = "http://hk.finance.yahoo.com/d/quotes.csv?s=<StockID>.HK&f=sl1d1t1c1ohgv&e=.csv" + sMarket(4,5) = "编号" + sMarket(4,6) = "zh" + sMarket(4,7) = "HK" + sMarket(4,8) = "C04" + sMarket(4,9) = "44" + sMarket(4,10) = "1" + + sMarket(5,0) = "澳元" + sMarket(5,1) = "$" + sMarket(5,2) = "悉尼" + sMarket(5,3) = "http://au.finance.yahoo.com/d/quotes.csv?s=<StockID>&f=sl1d1t1c1ohgv&e=.csv" + sMarket(5,5) = "股票代码" + sMarket(5,6) = "en" + sMarket(5,7) = "AU" + sMarket(5,8) = "C09" + sMarket(5,9) = "44" + sMarket(5,10) = "1" + +' ****************************End of the default subset********************************* + CompleteMarketList() + + LocalizedCurrencies() + + With TransactModel + .lblStockNames.Label = sStockname + .lblQuantity.Label = "数量" + .lblRate.Label = "股票牌价" + .lblDate.Label = "交易日期" + .hlnCommission.Label = "其它支出费用" + .lblCommission.Label = "手续费" + .lblMinimum.Label = "最低手续费" + .lblFix.Label = "固定金额/费用" + .cmdGoOn.Label = sOK + .cmdCancel.Label = sCancel + End With + + With StockRatesModel + .optPerShare.Label = "每股红利" + .optTotal.Label = "红利总计" + .lblDividend.Label = "金额" + .lblExchangeRate.Label = "兑换率(旧->新)" + .lblColon.Label = ":" + .lblDate.Label = "兑换日期:" + .lblStockNames.Label = sStockname + .lblStartDate.Label = sStartDate + .lblEndDate.Label = sEndDate + .optDaily.Label = "每天" + .optWeekly.Label = "每周" + .hlnInterval.Label = "时间周期" + .cmdGoOn.Label = sOk + .cmdCancel.Label = sCancel + End With +End Sub + \ No newline at end of file diff --git a/wizards/source/depot/dialog.xlb b/wizards/source/depot/dialog.xlb new file mode 100644 index 000000000..764ea3f35 --- /dev/null +++ b/wizards/source/depot/dialog.xlb @@ -0,0 +1,7 @@ + + + + + + + diff --git a/wizards/source/depot/script.xlb b/wizards/source/depot/script.xlb new file mode 100644 index 000000000..372665b22 --- /dev/null +++ b/wizards/source/depot/script.xlb @@ -0,0 +1,19 @@ + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/depot/tools.xba b/wizards/source/depot/tools.xba new file mode 100644 index 000000000..daadf4988 --- /dev/null +++ b/wizards/source/depot/tools.xba @@ -0,0 +1,217 @@ + + + +REM ***** BASIC ***** +Option Explicit + +Sub RemoveSheet() + If oSheets.HasbyName("Link") then + oSheets.RemovebyName("Link") + End If +End Sub + + +Sub InitializeStatusLine(StatusText as String, MaxValue as Integer, FirstValue as Integer) + oStatusline = oDocument.GetCurrentController.GetFrame.CreateStatusIndicator() + oStatusLine.Start(StatusText, MaxValue) + oStatusline.SetValue(FirstValue) +End Sub + + +Sub MakeRangeVisible(oSheet as Object, RangeName as String, BIsVisible as Boolean) +Dim oRangeAddress, oColumns as Object +Dim i, iStartColumn, iEndColumn as Integer + oRangeAddress = oSheet.GetCellRangeByName(RangeName).RangeAddress + iStartColumn = oRangeAddress.StartColumn + iEndColumn = oRangeAddress.EndColumn + oColumns = oSheet.Columns + For i = iStartColumn To iEndColumn + oSheet.Columns(i).IsVisible = bIsVisible + Next i +End Sub + + +Function GetRowIndex(oSheet as Object, RowName as String) +Dim oRange as Object + oRange = oSheet.GetCellRangeByName(RowName) + GetRowIndex = oRange.RangeAddress.StartRow +End Function + + +Function GetTransactionCount(iStartRow as Integer) +Dim iEndRow as Integer + iStartRow = GetRowIndex(oMovementSheet, "ColumnsToHide") + iEndRow = GetRowIndex(oMovementSheet, "HiddenRow3" ) + GetTransactionCount = iEndRow -iStartRow - 2 +End Function + + +Function GetStocksCount(iStartRow as Integer) +Dim iEndRow as Integer + iStartRow = GetRowIndex(oFirstSheet, "HiddenRow1") + iEndRow = GetRowIndex(oFirstSheet, "HiddenRow2") + GetStocksCount = iEndRow -iStartRow - 1 +End Function + + +Function FillListbox(ListboxControl as Object, MsgTitle as String, bShowMessage) as Boolean +Dim i, StocksCount as Integer +Dim iStartRow as Integer +Dim oCell as Object + ' Add stock names to empty list box + StocksCount = GetStocksCount(iStartRow) + If StocksCount > 0 Then + ListboxControl.Model.StringItemList() = NullList() + For i = 1 To StocksCount + oCell = oFirstSheet.GetCellByPosition(SBCOLUMNNAME1,iStartRow + i) + ListboxControl.AddItem(oCell.String, i-1) + Next + FillListbox() = True + Else + If bShowMessage Then + Msgbox(sInsertStockName, 16, MsgTitle) + FillListbox() = False + End If + End If +End Function + + +Sub CellValuetoControl(oSheet, oControl as Object, CellName as String) +Dim oCell as Object +Dim StringValue + oCell = GetCellByName(oSheet, CellName) + If oControl.PropertySetInfo.HasPropertyByName("EffectiveValue") Then + oControl.EffectiveValue = oCell.Value + Else + oControl.Value = oCell.Value + End If +' If oCell.FormulaResultType = 1 Then +' StringValue = oNumberFormatter.GetInputString(oCell.NumberFormat, oCell.Value) +' oControl.Text = DeleteStr(StringValue, "%") +' Else +' oControl.Text = oCell.String +' End If +End Sub + + +Sub RemoveStockRows(oSheet as Object, iStartRow, RowCount as Integer) + If RowCount > 0 Then + oSheet.Rows.RemoveByIndex(iStartRow, RowCount) + End If +End Sub + + +Sub AddValueToCellContent(iCellCol, iCellRow as Integer, AddValue) +Dim oCell as Object +Dim OldValue + oCell = oMovementSheet.GetCellByPosition(iCellCol, iCellRow) + OldValue = oCell.Value + oCell.Value = OldValue + AddValue +End Sub + + +Sub CheckInputDate(aEvent as Object) +Dim oRefDialog as Object +Dim oRefModel as Object +Dim oDateModel as Object + oDateModel = aEvent.Source.Model + oRefModel = DlgReference.GetControl("cmdGoOn").Model + oRefModel.Enabled = oDateModel.Date <> 0 +End Sub + + + +' Updates the cell with the CurrentValue after checking if the +' Newdate is later than the one that is referred to in the annotation +' of the cell +Sub InsertCurrentValue(CurValue as Double, iRow as Integer, Newdate as Date) +Dim oCell as Object +Dim OldDate as Date + oCell = oFirstSheet.GetCellByPosition(SBCOLUMNRATE1, iRow) + OldDate = CDate(oCell.Annotation.Text.String) + If NewDate >= OldDate Then + oCell.SetValue(CurValue) + oCell.Annotation.Text.SetString(CStr(NewDate)) + End If +End Sub + + +Sub SplitCellValue(oSheet, FirstNumber, SecondNumber, iCol, iRow, NoteText) +Dim oCell as Object +Dim OldValue + oCell = oSheet.GetCellByPosition(iCol, iRow) + OldValue = oCell.Value + oCell.Value = OldValue * FirstNumber / SecondNumber + If NoteText <> "" Then + oCell.Annotation.SetString(NoteText) + End If +End Sub + + +Function GetStockRowIndex(ByVal Stockname) as Integer +Dim i, StocksCount as Integer +Dim iStartRow as Integer +Dim oCell as Object + StocksCount = GetStocksCount(iStartRow) + For i = 1 To StocksCount + oCell = oFirstSheet.GetCellByPosition(SBCOLUMNNAME1,iStartRow + i) + If oCell.String = Stockname Then + GetStockRowIndex = iStartRow + i + Exit Function + End If + Next + GetStockRowIndex = -1 +End Function + + +Function GetStockID(StockName as String, Optional iFirstRow as Integer) as String +Dim CellStockName as String +Dim i as Integer +Dim iCount as Integer +Dim iLastRow as Integer + If IsMissing(iFirstRow) Then + iFirstRow = GetRowIndex(oFirstSheet, "HiddenRow1") + End If + iCount = GetStocksCount(iFirstRow) + iLastRow = iFirstRow + iCount + For i = iFirstRow To iLastRow + CellStockName = oFirstSheet.GetCellByPosition(SBCOLUMNNAME1, i).String + If CellStockname = StockName Then + Exit For + End If + Next i + If i > iLastRow Then + GetStockID() = "" + Else + If Not IsMissing(iFirstRow) Then + iFirstRow = i + End If + GetStockID() = oFirstSheet.GetCellByPosition(SBCOLUMNID1, i).String + End If +End Function + + +Function CheckDocLocale(LocLanguage as String, LocCountry as String) +Dim bIsDocLanguage as Boolean +Dim bIsDocCountry as Boolean + bIsDocLanguage = Instr(1, LocLanguage, sDocLanguage, SBBINARY) <> 0 + bIsDocCountry = Instr(1, LocCountry, sDocCountry, SBBINARY) <> 0 OR SDocCountry = "" + CheckDocLocale = (bIsDocLanguage And bIsDocCountry) +End Function + diff --git a/wizards/source/euro/AutoPilotRun.xba b/wizards/source/euro/AutoPilotRun.xba new file mode 100644 index 000000000..77ca182df --- /dev/null +++ b/wizards/source/euro/AutoPilotRun.xba @@ -0,0 +1,415 @@ + + + +Option Explicit + +Public SourceDir as String +Public TargetDir as String +Public TargetStemDir as String +Public SourceFile as String +Public TargetFile as String +Public Source as String +Public SubstFile as String +Public SubstDir as String +Public NoArgs() +Public TypeList(6) as String +Public GoOn as Boolean +Public DoUnprotect as Integer +Public Password as String +Public DocIndex as Integer +Public oPathSettings as Object +Public oUcb as Object +Public TotDocCount as Integer +Public sTotDocCount as String +Public OpenProperties(1) as New com.sun.star.beans.PropertyValue + + +Sub StartAutoPilot() +Dim i As Integer +Dim oFactoryKey as Object + BasicLibraries.LoadLibrary("Tools") + BasicLibraries.LoadLibrary("ImportWizard") + If InitResources("Euro Converter") Then + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + oLocale = GetStarOfficeLocale() + InitializeConverter(oLocale, 2) + ToggleGoOnButton() + oFactoryKey = GetRegistryKeyContent("org.openoffice.Setup/Office/Factories") + DialogModel.chkTextDocuments.Enabled = oFactoryKey.hasbyName("com.sun.star.text.TextDocument") + DialogModel.cmdGoOn.DefaultButton = True + DialogModel.lstCurrencies.TabIndex = 12 + DialogConvert.GetControl("optWholeDir").SetFocus() + DialogConvert.Execute() + DialogConvert.Dispose() + End If +End Sub + + +Sub ConvertDocuments() +Dim FilesList() +Dim bDisposable as Boolean + + If Source <> "" And TargetDir <> "" Then + If DialogModel.optSingleFile.State = 1 Then + SourceFile = Source + TotDocCount = 1 + Else + SourceDir = Source + TargetStemDir = TargetDir + TypeList(0) = "calc8" + TypeList(1) = "calc_StarOffice_XML_Calc" + If DialogModel.chkTextDocuments.State = 1 Then + ReDim Preserve TypeList(5) as String + + TypeList(2) = "writer8" + TypeList(3) = "writerglobal8" + TypeList(4) = "writer_StarOffice_XML_Writer" + TypeList(5) = "writer_globaldocument_StarOffice_XML_Writer_GlobalDocument" + End If + FilesList() = ReadDirectories(SourceDir, bRecursive, True, False, TypeList()) + TotDocCount = Ubound(FilesList(),1) + 1 + End If + InitializeProgressPage(DialogModel) +' ChangeToNextProgressStep() + sTotDocCount = CStr(TotDocCount) + OpenProperties(0).Name = "Hidden" + OpenProperties(0).Value = True + OpenProperties(1).Name = "AsTemplate" + OpenProperties(1).Value = False + For DocIndex = 0 To TotDocCount - 1 + If InitializeDocument(FilesList(), bDisposable) Then + If StoreDocument() Then + ConvertDocument() + oDocument.Store + End If + If bDisposable Then + oDocument.Dispose() + End If + End If + Next DocIndex + DialogModel.cmdBack.Enabled = True + DialogModel.cmdGoOn.Enabled = True + DialogModel.cmdGoOn.Label = sReady + DialogModel.cmdCancel.Label = sEnd + End If +End Sub + + +Function InitializeDocument(FilesList(), bDisposable as Boolean) as Boolean +' The Autopilot is started from step No. 2 +Dim sViewPath as String +Dim bIsReadOnly as Boolean +Dim sExtension as String + On Local Error Goto NEXTFILE + If Not bCancelTask Then + If DialogModel.optWholeDir.State = 1 Then + SourceFile = FilesList(DocIndex,0) + TargetFile = ReplaceString(SourceFile,TargetStemDir,SourceDir) + TargetDir = DirectorynameoutofPath(TargetFile, "/") + Else + SourceFile = Source + TargetFile = TargetDir & "/" & FileNameoutofPath(SourceFile, "/") + End If + If CreateFolder(TargetDir) Then + sExtension = GetFileNameExtension(SourceFile, "/") + oDocument = OpenDocument(SourceFile, OpenProperties(), bDisposable) + If (oDocument.IsReadOnly) AND (UCase(SourceFile) = UCase(TargetFile)) Then + bIsReadOnly = True + Msgbox(sMsgDOCISREADONLY, 16, GetProductName()) + Else + bIsReadOnly = False + RetrieveDocumentObjects() + sViewPath = CutPathView(SourceFile, 60) + DialogModel.lblCurDocument.Label = Str(DocIndex+1) & "/" & sTotDocCount & " (" & sViewPath & ")" + End If + InitializeDocument() = Not bIsReadOnly + Else + InitializeDocument() = False + End If + Else + InitializeDocument() = False + End If +NEXTFILE: + If Err <> 0 Then + InitializeDocument() = False + Resume LETSGO +LETSGO: + End If +End Function + + +Sub ChangeToNextProgressStep() + DialogModel.lblCurProgress.FontWeight = com.sun.star.awt.FontWeight.NORMAL + DialogConvert.GetControl("lblCurProgress").Visible = True +End Sub + + +Function StoreDocument() as Boolean +Dim sCurFileExists as String +Dim iOverWrite as Integer + If (TargetFile <> "") And (Not bCancelTask) Then + On Local Error Goto NOSAVING + If oUcb.Exists(TargetFile) Then + sCurFileExists = ReplaceString(sMsgFileExists, ConvertFromUrl(TargetFile), "<1>") + sCurFileExists = ReplaceString(sCurFileExists, chr(13), "<CR>") + iOverWrite = Msgbox (sCurFileExists, 32 + 3, sMsgDLGTITLE) + Select Case iOverWrite + Case 1 ' OK + Case 2 ' Abort + bCancelTask = True + StoreDocument() = False + Exit Function + Case 7 ' No + StoreDocument() = False + Exit Function + End Select + End If + If TargetFile <> SourceFile Then + oDocument.StoreAsUrl(TargetFile,NoArgs) + Else + oDocument.Store + End If + StoreDocument() = True + NOSAVING: + If Err <> 0 Then + StoreDocument() = False + Resume CLERROR + End If + CLERROR: + End If +End Function + + +Sub SwapExtent() + DialogModel.chkRecursive.Enabled = DialogModel.optWholeDir.State = 1 + If DialogModel.optWholeDir.State = 1 Then + DialogModel.lblSource.Label = sSOURCEDIR + If Not IsNull(SubstFile) Then + SubstFile = DialogModel.txtSource.Text + DialogModel.txtSource.Text = SubstDir + End If + Else + DialogModel.LblSource.Label = sSOURCEFILE + If Not IsNull(SubstDir) Then + SubstDir = DialogModel.txtSource.Text + DialogModel.txtSource.Text = SubstFile + End If + End If + ToggleGoOnButton() +End Sub + + +Function InitializeThirdStep() as Boolean +Dim TextBoxText as String + Source = AssignFileName(DialogModel.txtSource.Text, DialogModel.lblSource.Label, True) + If CheckTextBoxPath(DialogModel.txtTarget, True, True, sMsgDLGTITLE, True) Then + TargetDir = AssignFileName(DialogModel.txtTarget.Text, DialogModel.lblTarget.Label, False) + Else + TargetDir = "" + End If + If Source <> "" And TargetDir <> "" Then + bRecursive = DialogModel.chkRecursive.State = 1 + bDoUnprotect = DialogModel.chkProtect.State = 1 + DialogModel.lblRetrieval.FontWeight = com.sun.star.awt.FontWeight.BOLD + DialogModel.lblRetrieval.Label = sPrgsRETRIEVAL + DialogModel.lblCurProgress.Label = sPrgsCONVERTING + If DialogModel.optWholeDir.State = 1 Then + TextBoxText = sSOURCEDIR & " " & ConvertFromUrl(Source) & chr(13) + If DialogModel.chkRecursive.State = 1 Then + TextBoxText = TextBoxText & DeleteStr(sInclusiveSubDir,"~") & chr(13) + End If + Else + TextBoxText = sSOURCEFILE & " " & ConvertFromUrl(Source) & chr(13) + End If + TextBoxText = TextBoxText & sTARGETDIR & " " & ConvertFromUrl(TargetDir) & chr(13) + If DialogModel.chkProtect.State = 1 Then + TextBoxText = TextboxText & sPrgsUNPROTECT + End If + DialogModel.txtConfig.Text = TextBoxText + ToggleProgressStep() + DialogModel.cmdGoOn.Enabled = False + InitializeThirdStep() = True + Else + InitializeThirdStep() = False + End If +End Function + + +Sub ToggleProgressStep(Optional aEvent as Object) +Dim bMakeVisible as Boolean +Dim LocStep as Integer + ' If the Sub is call by the 'cmdBack' Button then set the 'bMakeVisible' variable accordingly + bMakeVisible = IsMissing(aEvent) + If bMakeVisible Then + DialogModel.Step = 3 + Else + DialogModel.Step = 2 + End If + DialogConvert.GetControl("lblCurrencies").Visible = Not bMakeVisible + DialogConvert.GetControl("lstCurrencies").Visible = Not bMakeVisible + DialogConvert.GetControl("cmdBack").Visible = bMakeVisible + DialogConvert.GetControl("cmdGoOn").Visible = bMakeVisible + DialogModel.imgPreview.ImageUrl = BitmapDir & "euro_" & DialogModel.Step & ".png" +End Sub + + +Sub EnableStep2DialogControls(OnValue as Boolean) + With DialogModel + .hlnExtent.Enabled = OnValue + .optWholeDir.Enabled = OnValue + .optSingleFile.Enabled = OnValue + .chkProtect.Enabled = OnValue + .cmdCallSourceDialog.Enabled = OnValue + .cmdCallTargetDialog.Enabled = OnValue + .lblSource.Enabled = OnValue + .lblTarget.Enabled = OnValue + .txtSource.Enabled = OnValue + .txtTarget.Enabled = OnValue + .imgPreview.Enabled = OnValue + .lstCurrencies.Enabled = OnValue + .lblCurrencies.Enabled = OnValue + If OnValue Then + ToggleGoOnButton() + .chkRecursive.Enabled = .optWholeDir.State = 1 + Else + .cmdGoOn.Enabled = False + .chkRecursive.Enabled = False + End If + End With +End Sub + + +Sub InitializeProgressPage() + DialogConvert.GetControl("lblRetrieval").Visible = False + DialogConvert.GetControl("lblCurProgress").Visible = False + DialogModel.lblRetrieval.FontWeight = com.sun.star.awt.FontWeight.NORMAL + DialogModel.lblCurProgress.FontWeight = com.sun.star.awt.FontWeight.BOLD + DialogConvert.GetControl("lblRetrieval").Visible = True + DialogConvert.GetControl("lblCurProgress").Visible = True +End Sub + + +Function AssignFileName(sPath as String, ByVal HeaderString, bCheckFileType as Boolean) as String +Dim bIsValid as Boolean +Dim sLocMimeType as String +Dim sNoDirMessage as String + HeaderString = DeleteStr(HeaderString, ":") + sPath = ConvertToUrl(Trim(sPath)) + bIsValid = oUcb.Exists(sPath) + If bIsValid Then + If DialogModel.optSingleFile.State = 1 Then + If bCheckFileType Then + sLocMimeType = GetRealFileContent(sPath) + If DialogModel.chkTextDocuments.State = 1 Then + If (Instr(1, sLocMimeType, "text") = 0) And (Instr(1, sLocMimeType, "calc") = 0) Then + Msgbox(sMsgFileInvalid, 48, sMsgDLGTITLE) + bIsValid = False + End If + Else + If (Instr(1, sLocMimeType, "spreadsheet") = 0) And (Instr(1, sLocMimeType, "calc")) = 0 Then + Msgbox(sMsgFileInvalid, 48, sMsgDLGTITLE) + bIsValid = False + End If + End If + End If + Else + If Not oUcb.IsFolder(sPath) Then + sNoDirMessage = ReplaceString(sMsgNODIRECTORY,sPath,"<1>") + Msgbox(sNoDirMessage,48, sMsgDLGTITLE) + bIsValid = False + Else + sPath = RTrimStr(sPath,"/") + sPath = sPath & "/" + End If + End if + Else + Msgbox(HeaderString & " '" & ConvertFromUrl(sPath) & "' " & sMsgNOTTHERE,48, sMsgDLGTITLE) + End If + If bIsValid Then + AssignFileName() = sPath + Else + AssignFilename() = "" + End If +End Function + + +Sub ToggleGoOnButton() +Dim bDoEnable as Boolean +Dim sLocMimeType as String +Dim sPath as String + bDoEnable = Ubound(DialogModel.lstCurrencies.SelectedItems()) > -1 + If bDoEnable Then + ' Check if Source is set correctly + sPath = ConvertToUrl(Trim(DialogModel.txtSource.Text)) + bDoEnable = oUcb.Exists(sPath) + End If + DialogModel.cmdGoOn.Enabled = bDoEnable +End Sub + + +Sub CallFolderPicker() + GetFolderName(DialogModel.txtTarget) + ToggleGoOnButton() +End Sub + + +Sub CallFilePicker() + If DialogModel.optSingleFile.State = 1 Then + Dim oMasterKey as Object + Dim oTypes() as Object + Dim oUIKey() as Object + + oMasterKey = GetRegistryKeyContent("org.openoffice.TypeDetection.Types") + oTypes() = oMasterKey.Types + oUIKey = GetRegistryKeyContent("org.openoffice.Office.UI/FilterClassification/LocalFilters") + If DialogModel.chkTextDocuments.State = 1 Then + Dim FilterNames(7,1) as String + FilterNames(4,0) = oTypes.GetByName("writer_StarOffice_XML_Writer").UIName + FilterNames(4,1) = "*.sxw" + FilterNames(5,0) = oTypes.GetByName("writer_StarOffice_XML_Writer_Template").UIName + FilterNames(5,1) = "*.stw" + FilterNames(6,0) = oTypes.GetByName("writer8").UIName + FilterNames(6,1) = "*.odt" + FilterNames(7,0) = oTypes.GetByName("writer8_template").UIName + FilterNames(7,1) = "*.ott" + Else + ReDim FilterNames(3,1) as String + End If + FilterNames(0,0) = oTypes.GetByName("calc8").UIName + Filternames(0,1) = "*.ods" + FilterNames(1,0) = oTypes.GetByName("calc8_template").UIName + Filternames(1,1) = "*.ots" + FilterNames(2,0) = oTypes.GetByName("calc_StarOffice_XML_Calc").UIName + Filternames(2,1) = "*.sxc" + FilterNames(3,0) = oTypes.GetByName("calc_StarOffice_XML_Calc_Template").UIName + Filternames(3,1) = "*.stc" + GetFileName(DialogModel.txtSource, Filternames()) + Else + GetFolderName(DialogModel.txtSource) + End If + ToggleGoOnButton() +End Sub + + +Sub PreviousStep() + DialogModel.Step = 2 + DialogModel.cmdGoOn.Label = sGOON + DialogModel.cmdCancel.Label = sCANCEL +End Sub + diff --git a/wizards/source/euro/Common.xba b/wizards/source/euro/Common.xba new file mode 100644 index 000000000..550042ee9 --- /dev/null +++ b/wizards/source/euro/Common.xba @@ -0,0 +1,289 @@ + + + + REM ***** BASIC ***** +Public DialogModel as Object +Public DialogConvert as Object +Public DialogPassword as Object +Public PasswordModel as Object + +Sub RetrieveDocumentObjects() + CurMimeType = Tools.GetDocumentType(oDocument) + If Instr(1, CurMimeType, "calc") <> 0 Then + oSheets = oDocument.Sheets + oSheet = oDocument.Sheets.GetbyIndex(0) + oAddressRanges = oDocument.createInstance("com.sun.star.sheet.SheetCellRanges") + End If + ' Retrieve the indices for the cellformatations + oFormats = oDocument.NumberFormats +End Sub + + +Sub CancelTask() +' If Not DocDisposed Then +' ReprotectSheets() +' End If + If DialogModel.Step = 3 And (Not bCancelTask) Then + If Msgbox(sMsgCancelConversion, 36, sMsgCancelTitle) = 6 Then + bCancelTask = True + DialogConvert.EndExecute + Else + bCancelTask = False + End If + Else + DialogConvert.EndExecute() + End If +End Sub + + +Function ConvertDocument() + GoOn = True +' DocDisposed = True + InitializeProgressbar() + If Instr(1, CurMimeType, "calc") <> 0 Then + bDocHasProtectedSheets = CheckSheetProtection(oSheets) + If bDocHasProtectedSheets Then + bDocHasProtectedSheets = UnprotectSheetsWithPassword(oSheets, bDoUnProtect) + End If + If Not bDocHasProtectedSheets Then + If Not bRangeListDefined Then + TotCellCount = 0 + CreateRangeEnumeration(True) + Else + IncreaseStatusvalue(SBRelGet/3) + End If + RangeIndex = Ubound(RangeList()) + If RangeIndex > -1 Then + ConvertThehardWay(RangeList(), True, False) + MakeStyleEnumeration(True) + oDocument.calculateAll() + End If + ReprotectSheets() + bRangeListDefined = False + End If + Else + DialogModel.ProgressBar.ProgressValue = 10 ' oStatusline.SetValue(10) + ConvertTextFields() + DialogModel.ProgressBar.ProgressValue = 80 ' oStatusline.SetValue(80) + ConvertWriterTables() + End If + EndStatusLine() + On Local Error Goto 0 +End Function + + +Sub SwitchNumberFormat(oObject as Object, oFormats as object) +Dim nFormatLanguage as Integer +Dim nFormatDecimals as Integer +Dim nFormatLeading as Integer +Dim bFormatLeading as Integer +Dim bFormatNegRed as Integer +Dim bFormatThousands as Integer +Dim i as Integer +Dim aNewStr as String +Dim iNumberFormat as Long +Dim AddToList as Boolean +Dim sOldCurrSymbol as String + On Local Error Resume Next + iNumberFormat = oObject.NumberFormat + On Local Error GoTo NOKEY + aFormat() = oFormats.getByKey(iNumberFormat) + On Local Error GoTo 0 + sOldCurrSymbol = aFormat.CurrencySymbol + If sOldCurrSymbol = CurrValue(CurrIndex,5) Then + aSimpleStr = "0 [$EUR]" + Else + aSimpleStr = "0 [$" & sEuroSign & aFormat.CurrencyExtension & "]" + End If + + nSimpleKey = Numberformat(oFormats, aSimpleStr, oLocale) + ' set new Currency format with according settings + nFormatDecimals = 2 + nFormatLeading = aFormat.LeadingZeros + bFormatNegRed = aFormat.NegativeRed + bFormatThousands = aFormat.ThousandsSeparator + aNewStr = oFormats.generateFormat( nSimpleKey, aFormat.Locale, bFormatThousands, bFormatNegRed, nFormatDecimals, nFormatLeading) + oObject.NumberFormat = Numberformat(oFormats, aNewStr, aFormat.Locale) + NOKEY: + If Err <> 0 Then + Resume CLERROR + End If + CLERROR: +End Sub + + +Function Numberformat( oFormats as Object, aFormatStr as String, oLocale as Object) +Dim nRetkey +Dim l as String +Dim c as String + nRetKey = oFormats.queryKey( aFormatStr, oLocale, True ) + If nRetKey = -1 Then + l = oLocale.Language + c = oLocale.Country + nRetKey = oFormats.addNew( aFormatStr, oLocale ) + If nRetKey = -1 Then nRetKey = 0 + End If + Numberformat = nRetKey +End Function + + +Function CheckFormatType( FormatObject as object) +Dim i as Integer +Dim LocCurrIndex as Integer +Dim nFormatFormatString as String +Dim FormatLangID as Integer +Dim sFormatCurrExt as String +Dim oFormatofObject() as Object + + ' Retrieve the Format of the Object + On Local Error GoTo NOKEY + oFormatofObject = oFormats.getByKey(FormatObject.NumberFormat) + On Local Error GoTo 0 + If NOT INT(oFormatofObject.Type) AND com.sun.star.util.NumberFormat.CURRENCY Then + CheckFormatType = False + Exit Function + End If + If FieldInArray(CurrSymbolList(),2,oFormatofObject.CurrencySymbol) Then + ' If the Currencysymbol of the object is the one needed, then check the Currency extension + sFormatCurrExt = oFormatofObject.CurrencyExtension + + If FieldInList(CurExtension(),2,sFormatCurrExt) Then + ' The Currency - extension also fits + CheckFormatType = True + Else + ' The Currency - symbol is Euro-conforming (like 'DEM'), so there is no Currency-Extension + CheckFormatType = oFormatofObject.CurrencySymbol = CurrsymbolList(2) + End If + Else + ' The Currency Symbol of the object is not the desired one + If oFormatofObject.CurrencySymbol = "" Then + ' Format is "automatic" + CheckFormatType = CheckLocale(oFormatofObject.Locale) + Else + CheckFormatType = False + End If + End If + + NOKEY: + If Err <> 0 Then + CheckFormatType = False + Resume CLERROR + End If + CLERROR: +End Function + + +Sub StartConversion() + GoOn = True + Select Case DialogModel.Step + Case 1 + If DialogModel.chkComplete.State = 1 Then + ConvertWholeDocument() + Else + ConvertRangesorStylesofDocument() + End If + Case 2 + bCancelTask = False + If InitializeThirdStep() Then + ConvertDocuments() + bCancelTask = True + End If + Case 3 + DialogConvert.EndExecute() + End Select +End Sub + + +Sub IncreaseStatusValue(AddStatusValue as Integer) + StatusValue = Int(StatusValue + AddStatusValue) + If DialogModel.Step = 3 Then + DialogModel.ProgressBar.ProgressValue = StatusValue + Else + oStatusline.SetValue(StatusValue) + End If +End Sub + + +Sub SelectCurrency() +Dim AddtoList as Boolean +Dim NullList() +Dim OldCurrIndex as Integer + bRangeListDefined = False + OldCurrIndex = CurrIndex + CurrIndex = DialogModel.lstCurrencies.SelectedItems(0) + If OldCurrIndex <> CurrIndex Then + InitializeCurrencyValues(CurrIndex) + CurExtension(0) = LangIDValue(CurrIndex,0,2) + CurExtension(1) = LangIDValue(CurrIndex,1,2) + CurExtension(2) = LangIDValue(CurrIndex,2,2) + If DialogModel.Step = 1 Then + EnableStep1DialogControls(False,False, False) + If DialogModel.optCellTemplates.State = 1 Then + EnableStep1DialogControls(False, False, False) + CreateStyleEnumeration() + ElseIf ((DialogModel.optSheetRanges.State = 1) OR (DialogModel.optDocRanges.State = 1)) AND (DialogModel.Step = 1) Then + CreateRangeEnumeration(False) + If Ubound(RangeList()) = -1 Then + DialogModel.lstSelection.StringItemList() = NullList() + End If + ElseIf DialogModel.optSelRange.State= 1 Then + 'Preselected Range + End If + EnableStep1DialogControls(True, True, True) + ElseIf DialogModel.Step = 2 Then + EnableStep2DialogControls(True) + End If + End If +End Sub + + +Sub FillUpCurrencyListbox() +Dim i as Integer +Dim MaxIndex as Integer + MaxIndex = Ubound(CurrValue(),1) + Dim LocList(MaxIndex) as String + For i = 0 To MaxIndex + LocList(i) = CurrValue(i,0) + Next i + DialogModel.lstCurrencies.StringItemList() = LocList() + If CurrIndex > -1 Then + SelectListboxItem(DialogModel.lstCurrencies, CurrIndex) + End If +End Sub + + +Sub InitializeProgressbar() + CurCellCount = 0 + If Not IsNull(oStatusLine) Then + oStatusline.Start(sStsPROGRESS, 100) + Else + DialogModel.ProgressBar.ProgressValue = 0 + End If + StatusValue = 0 +End Sub + + +Sub EndStatusLine() + If Not IsNull(oStatusLine) Then + oStatusline.End + Else + DialogModel.ProgressBar.ProgressValue = 100 + End If +End Sub + diff --git a/wizards/source/euro/ConvertRun.xba b/wizards/source/euro/ConvertRun.xba new file mode 100644 index 000000000..e91d12e7a --- /dev/null +++ b/wizards/source/euro/ConvertRun.xba @@ -0,0 +1,334 @@ + + + +Option Explicit + +Public oPreSelRange as Object + +Sub Main() + BasicLibraries.LoadLibrary("Tools") + If InitResources("Euro Converter") Then + bDoUnProtect = False + bPreSelected = True + oDocument = ThisComponent + RetrieveDocumentObjects() ' Statusline, SheetsCollection etc. + InitializeConverter(oDocument.CharLocale, 1) + GetPreSelectedRange() + If GoOn Then + DialogModel.lstCurrencies.TabIndex = 2 + DialogConvert.GetControl("chkComplete").SetFocus() + DialogConvert.Execute + End If + DialogConvert.Dispose + End If +End Sub + + +Sub SelectListItem() +Dim Listbox as Object +Dim oListSheet as Object +Dim CurStyleName as String +Dim oCursheet as Object +Dim oTempRanges as Object +Dim sCurSheetName as String +Dim RangeName as String +Dim oSheetRanges as Object +Dim ListIndex as Integer +Dim a as Integer +Dim i as Integer +Dim n as Integer +Dim m as Integer +Dim MaxIndex as Integer + Listbox = DialogModel.lstSelection + If Ubound(Listbox.SelectedItems()) > -1 Then + EnableStep1DialogControls(False, False, False) + oSelRanges = oDocument.createInstance("com.sun.star.sheet.SheetCellRanges") + + ' Is the sheet the basis, then the sheetobject has to be created + If DialogModel.optDocRanges.State = 1 Then + ' Document is the basis for the conversion + ListIndex = Listbox.SelectedItems(0) + oCurSheet = RetrieveSheetoutofRangeName(Listbox.StringItemList(ListIndex)) + oDocument.CurrentController.SetActiveSheet(oCurSheet) + Else + oCurSheet = oDocument.CurrentController.ActiveSheet + End If + sCurSheetName = oCurSheet.Name + If DialogModel.optCellTemplates.State = 1 Then + Dim CurIndex as Integer + For i = 0 To Ubound(Listbox.SelectedItems()) + CurIndex = Listbox.SelectedItems(i) + CurStylename = Listbox.StringItemList(CurIndex) + oSheetRanges = oCursheet.CellFormatRanges.createEnumeration + While oSheetRanges.hasMoreElements + oRange = oSheetRanges.NextElement + If oRange.getPropertyState("NumberFormat") = 1 Then + If oRange.CellStyle = CurStyleName Then + oSelRanges.InsertbyName("",oRange) + End If + End If + Wend + Next i + Else + ' Hard Formatation is selected + a = -1 + For n = 0 To Ubound(Listbox.SelectedItems()) + m = Listbox.SelectedItems(n) + RangeName = Listbox.StringItemList(m) + oListSheet = RetrieveSheetoutofRangeName(RangeName) + a = a + 1 + MaxIndex = Ubound(SelRangeList()) + If a > MaxIndex Then + Redim Preserve SelRangeList(MaxIndex + SBRANGEUBOUND) + End If + SelRangeList(a) = RangeName + If oListSheet.Name = sCurSheetName Then + oRange = RetrieveRangeoutofRangeName(RangeName) + oSelRanges.InsertbyName("",oRange) + End If + Next n + End If + If a > -1 Then + ReDim Preserve SelRangeList(a) + Else + ReDim SelRangeList() + End If + oDocument.CurrentController.Select(oSelRanges) + EnableStep1DialogControls(True, True, True) + End If +End Sub + + +' Procedure that is called by an event +Sub RetrieveEnableValue() +Dim EnableValue as Boolean + EnableValue = Not DialogModel.lstSelection.Enabled + EnableStep1DialogControls(True, EnableValue, True) +End Sub + + +Sub EnableStep1DialogControls(bCurrEnabled as Boolean, bFrameEnabled as Boolean, bButtonsEnabled as Boolean) +Dim bCurrIsSelected as Boolean +Dim bObjectIsSelected as Boolean +Dim bConvertWholeDoc as Boolean +Dim bDoEnableFrame as Boolean + bConvertWholeDoc = DialogModel.chkComplete.State = 1 + bDoEnableFrame = bFrameEnabled And (NOT bConvertWholeDoc) + + ' Controls around the Selection Listbox + With DialogModel + .lblCurrencies.Enabled = bCurrEnabled + .lstCurrencies.Enabled = bCurrEnabled + .lstSelection.Enabled = bDoEnableFrame + .lblSelection.Enabled = bDoEnableFrame + .hlnSelection.Enabled = bDoEnableFrame + .optCellTemplates.Enabled = bDoEnableFrame + .optSheetRanges.Enabled = bDoEnableFrame + .optDocRanges.Enabled = bDoEnableFrame + .optSelRange.Enabled = bDoEnableFrame + End With + ' The CheckBox has the Value '1' when the Controls in the Frame are disabled + If bButtonsEnabled Then + bCurrIsSelected = Ubound(DialogModel.lstCurrencies.SelectedItems()) <> -1 + ' Enable GoOnButton only when Currency is selected + DialogModel.cmdGoOn.Enabled = bCurrIsSelected + DialogModel.chkComplete.Enabled = bCurrIsSelected + If bDoEnableFrame AND DialogModel.cmdGoOn.Enabled Then + ' If FrameControls are enabled, check if Listbox is Empty + bObjectIsSelected = Ubound(DialogModel.lstSelection.SelectedItems()) <> -1 + DialogModel.cmdGoOn.Enabled = bObjectIsSelected + End If + Else + DialogModel.cmdGoOn.Enabled = False + DialogModel.chkComplete.Enabled = False + End If +End Sub + + +Sub ConvertRangesOrStylesOfDocument() +Dim i as Integer +Dim ItemName as String +Dim SelList() as String +Dim oSheetRanges as Object + + bDocHasProtectedSheets = CheckSheetProtection(oSheets) + If bDocHasProtectedSheets Then + bDocHasProtectedSheets = UnprotectSheetsWithPassWord(oSheets, bDoUnProtect) + DialogModel.cmdGoOn.Enabled = False + End If + If Not bDocHasProtectedSheets Then + EnableStep1DialogControls(False, False, False) + InitializeProgressBar() + If DialogModel.optSelRange.State = 1 Then + SelectListItem() + End If + SelList() = DialogConvert.GetControl("lstSelection").SelectedItems() + If DialogModel.optCellTemplates.State = 1 Then + ' Option 'Soft' Formatation is selected + AssignRangestoStyle(DialogModel.lstSelection.StringItemList(), SelList()) + ConverttheSoftWay(SelList(), True) + ElseIf DialogModel.optSelRange.State = 1 Then + oSheetRanges = oPreSelRange.CellFormatRanges.createEnumeration + While oSheetRanges.hasMoreElements + oRange = oSheetRanges.NextElement + If CheckFormatType(oRange) Then + ConvertCellCurrencies(oRange) + SwitchNumberFormat(oRange, oFormats, sEuroSign) + End If + Wend + Else + ConverttheHardWay(SelList(), False, True) + End If + oStatusline.End + EnableStep1DialogControls(True, False, True) + DialogModel.cmdGoOn.Enabled = True + oDocument.CurrentController.Select(oSelRanges) + End If +End Sub + + +Sub ConvertWholeDocument() +Dim s as Integer + DialogModel.cmdGoOn.Enabled = False + DialogModel.chkComplete.Enabled = False + GoOn = ConvertDocument() + EmptyListbox(DialogModel.lstSelection()) + EnableStep1DialogControls(True, True, True) +End Sub + + +' Everything previously selected will be deselected +Sub EmptySelection() +Dim RangeName as String +Dim i as Integer +Dim MaxIndex as Integer +Dim EmptySelRangeList() as String + + If Not IsNull(oSelRanges) Then + If oSelRanges.HasElements Then + EmptySelRangeList() = ArrayOutofString(oSelRanges.RangeAddressesasString, ";", MaxIndex) + For i = 0 To MaxIndex + oSelRanges.RemovebyName(EmptySelRangeList(i)) + Next i + End If + oDocument.CurrentController.Select(oSelRanges) + Else + oSelRanges = oDocument.createInstance("com.sun.star.sheet.SheetCellRanges") + End If +End Sub + + +Function AddSelectedRangeToSelRangesEnum() as Object +Dim oLocRange as Object + osheet = oDocument.CurrentController.GetActiveSheet + oSelRanges = oDocument.createInstance("com.sun.star.sheet.SheetCellRanges") + ' Check if a Currency-Range has been selected + oLocRange = oDocument.CurrentController.Selection + bPreSelected = oLocRange.SupportsService("com.sun.star.sheet.SheetCellRange") + If bPreSelected Then + oSelRanges.InsertbyName("",oLocRange) + AddSelectedRangeToSelRangesEnum() = oLocRange + End If +End Function + + +Sub GetPreSelectedRange() +Dim i as Integer +Dim OldCurrSymbolList(2) as String +Dim OldCurrIndex as Integer +Dim OldCurExtension(2) as String + oPreSelRange = AddSelectedRangeToSelRangesEnum() + + DialogModel.chkComplete.State = Abs(Not(bPreSelected)) + If bPreSelected Then + DialogModel.optSelRange.State = 1 + AddRangeToListbox(oPreSelRange) + Else + DialogModel.optCellTemplates.State = 1 + CreateStyleEnumeration() + End If + EnableStep1DialogControls(True, bPreSelected, True) + DialogModel.optSelRange.Enabled = bPreSelected +End Sub + + +Sub AddRangeToListbox(oLocRange as Object) + EmptyListBox(DialogModel.lstSelection) + PreName = RetrieveRangeNamefromAddress(oLocRange) + AddSingleItemToListbox(DialogModel.lstSelection, Prename)', 0) + SelectListboxItem(DialogModel.lstCurrencies, CurrIndex) + TotCellCount = CountRangeCells(oLocRange) +End Sub + + +Sub CheckRangeSelection(Optional oEvent) + EmptySelection() + AddRangeToListbox(oPreSelRange) + oPreSelRange = AddSelectedRangeToSelRangesEnum() +End Sub + + +' Checks if a Field (LocField) is already defined in an Array +' Returns 'True' or 'False' +Function FieldInList(LocList(), MaxIndex as integer, ByVal LocField ) As Boolean +Dim i as integer + LocField = UCase(LocField) + For i = Lbound(LocList()) to MaxIndex + If UCase(LocList(i)) = LocField then + FieldInList = True + Exit Function + End if + Next + FieldInList = False +End Function + + +Function CheckLocale(oLocale) as Boolean +Dim i as Integer +Dim LocCountry as String +Dim LocLanguage as String + LocCountry = oLocale.Country + LocLanguage = oLocale.Language + For i = 0 To 1 + If LocLanguage = LangIDValue(CurrIndex,i,0) AND LocCountry = LangIDValue(CurrIndex,i,1) Then + CheckLocale = True + Exit Function + End If + Next i + CheckLocale = False +End Function + + +Sub SetOptionValuestoNull() + With DialogModel + .optCellTemplates.State = 0 + .optSheetRanges.State = 0 + .optDocRanges.State = 0 + .optSelRange.State = 0 + End With +End Sub + + + +Sub SetStatusLineText(sStsREPROTECT as String) + If Not IsNull(oStatusLine) Then + oStatusline.SetText(sStsREPROTECT) + End If +End Sub + diff --git a/wizards/source/euro/DlgConvert.xdl b/wizards/source/euro/DlgConvert.xdl new file mode 100644 index 000000000..ff3f523a7 --- /dev/null +++ b/wizards/source/euro/DlgConvert.xdl @@ -0,0 +1,94 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/euro/DlgPassword.xdl b/wizards/source/euro/DlgPassword.xdl new file mode 100644 index 000000000..20beac046 --- /dev/null +++ b/wizards/source/euro/DlgPassword.xdl @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/euro/Hard.xba b/wizards/source/euro/Hard.xba new file mode 100644 index 000000000..467225dec --- /dev/null +++ b/wizards/source/euro/Hard.xba @@ -0,0 +1,246 @@ + + + +REM ***** BASIC ***** +Option Explicit + + +Sub CreateRangeList() +Dim MaxIndex as Integer + MaxIndex = -1 + EnableStep1DialogControls(False, False, False) + EmptySelection() + DialogModel.lblSelection.Label = sCURRRANGES + EmptyListbox(DialogModel.lstSelection) + oDocument.CurrentController.Select(oSelRanges) + If (DialogModel.optSheetRanges.State = 1) AND (DialogModel.chkComplete.State <> 1) Then + ' Conversion on a sheet? + SetStatusLineText(sStsRELRANGES) + osheet = oDocument.CurrentController.GetActiveSheet + oRanges = osheet.CellFormatRanges.createEnumeration() + MaxIndex = AddSheetRanges(oRanges, MaxIndex, oSheet, False) + If MaxIndex > -1 Then + ReDim Preserve RangeList(MaxIndex) + End If + Else + CreateRangeEnumeration(False) + bRangeListDefined = True + End If + EnableStep1DialogControls(True, True, True) + SetStatusLineText("") +End Sub + + +Sub CreateRangeEnumeration(bAutopilot as Boolean) +Dim i as Integer +Dim MaxIndex as integer +Dim sStatustext as String + MaxIndex = -1 + If Not bRangeListDefined Then + ' Cellranges are not yet defined + oSheets = oDocument.Sheets + For i = 0 To oSheets.Count-1 + oSheet = oSheets.GetbyIndex(i) + If bAutopilot Then + IncreaseStatusValue(SBRELGET/osheets.Count) + Else + sStatustext = ReplaceString(sStsRELSHEETRANGES,Str(i+1),"%1Number%1") + sStatustext = ReplaceString(sStatusText,oSheets.Count,"%2TotPageCount%2") + SetStatusLineText(sStatusText) + End If + oRanges = osheet.CellFormatRanges.createEnumeration + MaxIndex = AddSheetRanges(oRanges, MaxIndex, oSheet, bAutopilot) + Next i + Else + If Not bAutoPilot Then + SetStatusLineText(sStsRELRANGES) + ' cellranges already defined + For i = 0 To Ubound(RangeList()) + If RangeList(i) <> "" Then + AddSingleItemToListBox(DialogModel.lstSelection, RangeList(i)) + End If + Next + End If + End If + If MaxIndex > -1 Then + ReDim Preserve RangeList(MaxIndex) + Else + ReDim RangeList() + End If + Rangeindex = MaxIndex +End Sub + + +Function AddSheetRanges(oRanges as Object, r as Integer, oSheet as Object, bAutopilot) +Dim RangeName as String +Dim AddtoList as Boolean +Dim iCurStep as Integer +Dim MaxIndex as Integer + iCurStep = DialogModel.Step + While oRanges.hasMoreElements + oRange = oRanges.NextElement + AddToList = CheckFormatType(oRange) + If AddToList Then + RangeName = RetrieveRangeNamefromAddress(oRange) + TotCellCount = TotCellCount + CountRangeCells(oRange) + If Not bAutoPilot Then + AddSingleItemToListbox(DialogModel.lstSelection, RangeName) + End If + ' The Ranges are only passed to an Array when the whole Document is the basis + ' Redimension the RangeList Array if necessary + MaxIndex = Ubound(RangeList()) + r = r + 1 + If r > MaxIndex Then + MaxIndex = MaxIndex + SBRANGEUBOUND + ReDim Preserve RangeList(MaxIndex) + End If + RangeList(r) = RangeName + End If + Wend + AddSheetRanges = r +End Function + + +' adds a section to the collection +Sub SelectRange() +Dim i as Integer +Dim RangeName as String +Dim SelItem as String +Dim CurRange as String +Dim SheetRangeName as String +Dim DescriptionList() as String +Dim MaxRangeIndex as Integer +Dim StatusValue as Integer + StatusValue = 0 + MaxRangeIndex = Ubound(SelRangeList()) + CurSheetName = oSheet.Name + For i = 0 To MaxRangeIndex + SelItem = SelRangeList(i) + ' Is the Range already included in the collection? + oRange = RetrieveRangeoutOfRangename(SelItem) + TotCellCount = TotCellCount + CountRangeCells(oRange) + DescriptionList() = ArrayOutofString(SelItem,".",1) + SheetRangeName = DeleteStr(DescriptionList(0),"'") + If SheetRangeName = CurSheetName Then + oSelRanges.InsertbyName("",oRange) + End If + IncreaseStatusValue(SBRELGET/MaxRangeIndex) + Next i +End Sub + + +Sub ConvertThehardWay(ListboxList(), SwitchFormat as Boolean, bRemove as Boolean) +Dim i as Integer +Dim AddCells as Long +Dim OldStatusValue as Single +Dim RangeName as String +Dim LastIndex as Integer +Dim oSelListbox as Object + + oSelListbox = DialogConvert.GetControl("lstSelection") + Lastindex = Ubound(ListboxList()) + If TotCellCount > 0 Then + OldStatusValue = StatusValue + ' hard format + For i = 0 To LastIndex + RangeName = ListboxList(i) + oRange = RetrieveRangeoutofRangeName(RangeName) + ConvertCellCurrencies(oRange) + If bRemove Then + If oSelRanges.HasbyName(RangeName) Then + oSelRanges.RemovebyName(RangeName) + oDocument.CurrentController.Select(oSelRanges) + End If + End If + If SwitchFormat Then + If oRange.getPropertyState("NumberFormat") <> 1 Then + ' Range is hard formatted + SwitchNumberFormat(oRange, oFormats, sEuroSign) + End If + Else + SwitchNumberFormat(oRange, oFormats, sEuroSign) + End If + AddCells = CountRangeCells(oRange) + CurCellCount = AddCells + IncreaseStatusValue((CurCellCount/TotCellCount)*(100-OldStatusValue)) + If bRemove Then + RemoveListBoxItemByName(oSelListbox.Model,Rangename) + End If + Next + End If +End Sub + + +Sub ConvertCellCurrencies(oRange as Object) +Dim oValues as Object +Dim oCells as Object +Dim oCell as Object + oValues = oRange.queryContentCells(com.sun.star.sheet.CellFlags.VALUE) + If (oValues.Count > 0) Then + oCells = oValues.Cells.createEnumeration + While oCells.hasMoreElements + oCell = oCells.nextElement + ModifyObjectValuewithCurrFactor(oCell) + Wend + End If +End Sub + + +Sub ModifyObjectValuewithCurrFactor(oDocObject as Object) +Dim oDocObjectValue as double + oDocObjectValue = oDocObject.Value + oDocObject.Value = Round(oDocObjectValue/CurrFactor, 2) +End Sub + + +Function CheckIfRangeisCurrency(FormatObject as Object) +Dim oFormatofObject() as Object + ' Retrieve the Format of the Object + On Local Error GoTo NOKEY + oFormatofObject() = oFormats.getByKey(FormatObject.NumberFormat) + On Local Error GoTo 0 + CheckIfRangeIsCurrency = INT(oFormatofObject.Type) AND com.sun.star.util.NumberFormat.CURRENCY + Exit Function +NOKEY: + CheckIfRangeisCurrency = False + Resume CLERROR + CLERROR: +End Function + + +Function CountColumnsForRow(IndexArray() as String, Row as Integer) +Dim i as Integer +Dim NoNulls as Boolean + For i = 1 To Ubound(IndexArray,2) + If IndexArray(Row,i)= "" Then + NoNulls = False + Exit For + End If + Next + CountColumnsForRow = i +End Function + + +Function CountRangeCells(oRange as Object) As Long +Dim oRangeAddress as Object +Dim LocCellCount as Long + oRangeAddress = oRange.RangeAddress + LocCellCount = (oRangeAddress.EndColumn - oRangeAddress.StartColumn + 1) * (oRangeAddress.EndRow - oRangeAddress.StartRow + 1) + CountRangeCells = LocCellCount +End Function \ No newline at end of file diff --git a/wizards/source/euro/Init.xba b/wizards/source/euro/Init.xba new file mode 100644 index 000000000..623a0a53b --- /dev/null +++ b/wizards/source/euro/Init.xba @@ -0,0 +1,667 @@ + + + +Option Explicit +REM ***** BASIC ***** + +Public Const SBRANGEUBOUND = 20 +Public StyleRangeAssignmentList(SBRANGEUBOUND)as String +Public SelRangeList(SBRANGEUBOUND) as String +Public RangeList(SBRANGEUBOUND) as String +Public UnprotectList() as String +Public FilterNames(2,1) as String +Public bDoUnProtect as Boolean +Public bCancelTask as Boolean + +Public sREADY as String +Public sPROTECT as String +Public sCONTINUE as String + +Public sSELTEMPL as String +Public sSELCELL as String +Public sCURRRANGES as String +Public sTEMPLATES as String + +Public sSOURCEFILE as String +Public sSOURCEDIR as String +Public sTARGETDIR as String + +Public sStsPROGRESS as String +Public sStsCELLPROGRSS as String +Public sStsRELRANGES as String +Public sStsRELSHEETRANGES as String +Public sStsREPROTECT as String + +Public sMsgSELDIR as String +Public sMsgSELFILE as String +Public sMsgTARGETDIR as String +Public sMsgNOTTHERE as String +Public sMsgDLGTITLE as String +Public sMsgUNPROTECT as String +Public sMsgPWPROTECT as String +Public sMsgWRONGPW as String +Public sMsgSHEETPROTECTED as String +Public sMsgWARNING as String +Public sMsgSHEETSNOPROTECT as String +Public sMsgSHEETNOPROTECT as String +Public sMsgCHOOSECURRENCY as String +Public sMsgPASSWORD as String +Public sMsgOK as String +Public sMsgCANCEL as String +Public sMsgFileInvalid as String +Public sMsgNODIRECTORY as String +Public sMsgDOCISREADONLY as String +Public sMsgFileExists as String +Public sMsgCancelConversion as String +Public sMsgCancelTitle as String +Public sCurrPORTUGUESE as String +Public sCurrDUTCH as String +Public sCurrFRENCH as String +Public sCurrSPANISH as String +Public sCurrITALIAN as String +Public sCurrGERMAN as String +Public sCurrBELGIAN as String +Public sCurrIRISH as String +Public sCurrLUXEMBOURG as String +Public sCurrAUSTRIAN as String +Public sCurrFINNISH as String +Public sCurrGREEK as String +Public sCurrSLOVENIAN as String +Public sCurrCYPRIOT as String +Public sCurrMALTESE as String +Public sCurrSLOVAK as String +Public sCurrESTONIAN as String +Public sCurrLATVIAN as String +Public sCurrLITHUANIAN as String + +Public sPrgsRETRIEVAL as String +Public sPrgsCONVERTING as String +Public sPrgsUNPROTECT as String +Public sInclusiveSubDir as String + +Public Const SBCOUNTRYCOUNT = 19 +Public CurMimeType as String +Public CurCellCount as Long +Public oSheets as Object +Public oStyles as Object +Public oStyle as Object +Public oFormats as Object +Public aSimpleStr as String +Public nSimpleKey as Long +Public aFormat() as Variant +Public oRanges as Object +Public oRange as Object +Public nLanguage as integer +Public nFormatLanguage as integer +Public aCellFormat as Variant +Public oDocument as Object +Public StartCol, StartRow, EndCol, EndRow as String +Public oSheet as Object +Public IntStartCol, IntStartRow, IntEndCol, IntEndRow as integer +Public oSelRanges as Object +Public nFormatType as Integer +Public sFormatCurrency as String +Public sFormatLanguage as String +Public CurSheetName as String +Public oStatusLine as Object +Public Const SBRELGET = 50 +Public StatusValue as Single +Public TotCellCount as Long +Public StyleIndex as Integer +Public RangeIndex as Integer +Public CurrIndex as Integer +Public ActLangNumber(1) as Integer +Public CurExtension(2) as String +Public Currfactor as Double +Public CurrSymbolList(2) as String +Public CurrLanguage as String +Public CurrValue(18,5) +Public LangIDValue(18,2,2) as String +Public PreName as String +Public Separator as String +Public BitmapDir as String +Public TypeIndex as Integer, CSIndex as Integer, LangIndex as Integer, FSIndex as Integer +Public oLocale as New com.sun.star.lang.Locale +Public sEuroSign as String +Public oPointer as Object +Public sDocType as String +Public bPreSelected as Boolean +Public bRecursive as Boolean +Public bCancelProtection as Boolean +Public CurrRoundMode as Boolean +Public bRangeListDefined as Boolean +Public bDocHasProtectedSheets as Boolean +Public sGOON as String +Public sHELP as String +Public sCANCEL as String +Dim sEnd as String + +Sub InitializeResources() +Dim LocWorkPath as String + With DialogModel + ' Strings that are also needed by the Password Dialog + sGoOn = GetResText("STEP_ZERO_3") + sHelp = GetResText("STEP_ZERO_1") + sCANCEL = GetResText("MESSAGES_18") + sEnd = GetResText("STEP_ZERO_0") + sPROTECT = GetResText("STEP_ZERO_5") + sCONTINUE = GetResText("STEP_ZERO_7") + sSELTEMPL = GetResText("STEP_CONVERTER_6") + sSELCELL = GetResText("STEP_CONVERTER_7") + sCURRRANGES = GetResText("STEP_CONVERTER_8") + sTEMPLATES = GetResText("STEP_CONVERTER_9") + sStsPROGRESS = GetResText("STATUSLINE_0") + sStsCELLPROGRSS = GetResText("STATUSLINE_1") + sStsRELSHEETRANGES = GetResText("STATUSLINE_2") + sStsRELRANGES = GetResText("STATUSLINE_3") + sStsREPROTECT = GetResText("STATUSLINE_4") + sREADY = GetResText("MESSAGES_0") + sMsgSELDIR = GetResText("MESSAGES_1") + sMsgSELFILE = GetResText("MESSAGES_2") + sMsgTARGETDIR = GetResText("MESSAGES_3") + sMsgNOTTHERE = GetResText("MESSAGES_4") + sMsgDLGTITLE = GetResText("MESSAGES_5") + sMsgUNPROTECT = GetResText("MESSAGES_6") + sMsgPWPROTECT = GetResText("MESSAGES_7") + sMsgWRONGPW = GetResText("MESSAGES_8") + sMsgSHEETPROTECTED = GetResText("MESSAGES_9") + sMsgWARNING = GetResText("MESSAGES_10") + sMsgSHEETSNOPROTECT = GetResText("MESSAGES_11") + sMsgSHEETNOPROTECT = GetResText("MESSAGES_12") + sMsgCHOOSECURRENCY = GetResText("MESSAGES_15") + sMsgPASSWORD = GetResText("MESSAGES_16") + sMsgOK = GetResText("MESSAGES_17") + sMsgCANCEL = GetResText("MESSAGES_18") + sMsgFILEINVALID = GetResText("MESSAGES_19") + sMsgFILEINVALID = ReplaceString(sMsgFILEINVALID,"%PRODUCTNAME", GetProductname()) + SMsgNODIRECTORY = GetResText("MESSAGES_20") + sMsgDOCISREADONLY = GetResText("MESSAGES_21") + sMsgFileExists = GetResText("MESSAGES_22") + sMsgCancelConversion = GetResText("MESSAGES_23") + sMsgCancelTitle = GetResText("MESSAGES_24") + sCurrPORTUGUESE = GetResText("CURRENCIES_0") + sCurrDUTCH = GetResText("CURRENCIES_1") + sCurrFRENCH = GetResText("CURRENCIES_2") + sCurrSPANISH = GetResText("CURRENCIES_3") + sCurrITALIAN = GetResText("CURRENCIES_4") + sCurrGERMAN = GetResText("CURRENCIES_5") + sCurrBELGIAN = GetResText("CURRENCIES_6") + sCurrIRISH = GetResText("CURRENCIES_7") + sCurrLUXEMBOURG = GetResText("CURRENCIES_8") + sCurrAUSTRIAN = GetResText("CURRENCIES_9") + sCurrFINNISH = GetResText("CURRENCIES_10") + sCurrGREEK = GetResText("CURRENCIES_11") + sCurrSLOVENIAN = GetResText("CURRENCIES_12") + sCurrCYPRIOT = GetResText("CURRENCIES_13") + sCurrMALTESE = GetResText("CURRENCIES_14") + sCurrSLOVAK = GetResText("CURRENCIES_15") + sCurrESTONIAN = GetResText("CURRENCIES_16") + sCurrLATVIAN = GetResText("CURRENCIES_17") + sCurrLITHUANIAN = GetResText("CURRENCIES_18") + .cmdCancel.Label = sCANCEL + .cmdHelp.Label = sHELP + .cmdBack.Label = GetResText("STEP_ZERO_2") + .cmdGoOn.Label = sGOON + .lblHint.Label = GetResText("STEP_ZERO_4") + .lblCurrencies.Label = GetResText("STEP_ZERO_6") + .cmdBack.Enabled = False + If .Step = 1 Then + .chkComplete.Label = GetResText("STEP_CONVERTER_0") + .hlnSelection.Label = GetResText("STEP_CONVERTER_1") + .optCellTemplates.Label = GetResText("STEP_CONVERTER_2") + .optSheetRanges.Label = GetResText("STEP_CONVERTER_3") + .optDocRanges.Label = GetResText("STEP_CONVERTER_4") + .optSelRange.Label = GetResText("STEP_CONVERTER_5") + sCURRRANGES = GetResText("STEP_CONVERTER_8") + .lblSelection.Label = sCURRRANGES + Else + .lblProgress.Label = sStsPROGRESS + .hlnExtent.Label = GetResText("STEP_AUTOPILOT_0") + .optSingleFile.Label = GetResText("STEP_AUTOPILOT_1") + .optWholeDir.Label = GetResText("STEP_AUTOPILOT_2") + .chkProtect.Label = GetResText("STEP_AUTOPILOT_7") + .chkTextDocuments.Label = GetResText("STEP_AUTOPILOT_10") + + sSOURCEFILE = GetResText("STEP_AUTOPILOT_3") + sSOURCEDIR = GetResText("STEP_AUTOPILOT_4") + .lblSource.Label = sSOURCEDIR + sInclusiveSubDir = GetResText("STEP_AUTOPILOT_5") + .chkRecursive.Label = sInclusiveSubDir + sTARGETDIR = GetResText("STEP_AUTOPILOT_6") + .lblTarget.Label = STARGETDIR + + LocWorkPath = GetPathSettings("Work") + If Not oUcb.Exists(LocWorkPath) Then + ShowNoOfficePathError() + Stop + End If + + .txtSource.Text = ConvertfromUrl(LocWorkPath) + + SubstDir = .txtSource.Text + .txtTarget.Text = .txtSource.Text + .hlnProgress.Label = GetResText("STEP_LASTPAGE_0") + .lblConfig.Label = GetResText("STEP_LASTPAGE_3") + sPrgsRETRIEVAL = GetResText("STEP_LASTPAGE_1") + sPrgsCONVERTING = GetResText("STEP_LASTPAGE_2") + sPrgsUNPROTECT = GetResText("STEP_LASTPAGE_4") + End If + End With +End Sub + +Sub InitializeLanguages() + sEuroSign = chr(8364) + +' CURRENCIES_PORTUGUESE + LangIDValue(0,0,0) = "pt" + LangIDValue(0,0,1) = "" + LangIDValue(0,0,2) = "-816" + +' CURRENCIES_DUTCH + LangIDValue(1,0,0) = "nl" + LangIDValue(1,0,1) = "" + LangIDValue(1,0,2) = "-413" + +' CURRENCIES_FRENCH + LangIDValue(2,0,0) = "fr" + LangIDValue(2,0,1) = "" + LangIDValue(2,0,2) = "-40C" + +' CURRENCIES_SPANISH + LangIDValue(3,0,0) = "es" + LangIDValue(3,0,1) = "" + LangIDValue(3,0,2) = "-40A" + + 'Spanish modern + LangIDValue(3,1,0) = "es" + LangIDValue(3,1,1) = "" + LangIDValue(3,1,2) = "-C0A" + + 'Spanish katalanic + LangIDValue(3,2,0) = "es" + LangIDValue(3,2,1) = "" + LangIDValue(3,2,2) = "-403" + +' CURRENCIES_ITALIAN + LangIDValue(4,0,0) = "it" + LangIDValue(4,0,1) = "" + LangIDValue(4,0,2) = "-410" + +' CURRENCIES_GERMAN + LangIDValue(5,0,0) = "de" + LangIDValue(5,0,1) = "DE" + LangIDValue(5,0,2) = "-407" + +' CURRENCIES_BELGIAN + LangIDValue(6,0,0) = "fr" + LangIDValue(6,0,1) = "BE" + LangIDValue(6,0,2) = "-80C" + + LangIDValue(6,1,0) = "nl" + LangIDValue(6,1,1) = "BE" + LangIDValue(6,1,2) = "-813" + +' CURRENCIES_IRISH + LangIDValue(7,0,0) = "en" + LangIDValue(7,0,1) = "IE" + LangIDValue(7,0,2) = "-1809" + + LangIDValue(7,1,0) = "ga" + LangIDValue(7,1,1) = "IE" + LangIDValue(7,1,2) = "-83C" + +' CURRENCIES_LUXEMBOURG + LangIDValue(8,0,0) = "fr" + LangIDValue(8,0,1) = "LU" + LangIDValue(8,0,2) = "-140C" + + LangIDValue(8,1,0) = "de" + LangIDValue(8,1,1) = "LU" + LangIDValue(8,1,2) = "-1007" + +' CURRENCIES_AUSTRIAN + LangIDValue(9,0,0) = "de" + LangIDValue(9,0,1) = "AT" + LangIDValue(9,0,2) = "-C07" + +' CURRENCIES_FINNISH + LangIDValue(10,0,0) = "fi" + LangIDValue(10,0,1) = "FI" + LangIDValue(10,0,2) = "-40B" + + LangIDValue(10,1,0) = "sv" + LangIDValue(10,1,1) = "FI" + LangIDValue(10,1,2) = "-81D" + +' CURRENCIES_GREEK + LangIDValue(11,0,0) = "el" + LangIDValue(11,0,1) = "GR" + LangIDValue(11,0,2) = "-408" + +' CURRENCIES_SLOVENIAN + LangIDValue(12,0,0) = "sl" + LangIDValue(12,0,1) = "SI" + LangIDValue(12,0,2) = "-424" + +' CURRENCIES_CYPRIOT + LangIDValue(13,0,0) = "el" + LangIDValue(13,0,1) = "CY" + LangIDValue(13,0,2) = "-408" + +' CURRENCIES_MALTESE + LangIDValue(14,0,0) = "mt" + LangIDValue(14,0,1) = "MT" + LangIDValue(14,0,2) = "-43A" + +' CURRENCIES_SLOVAK + LangIDValue(15,0,0) = "sk" + LangIDValue(15,0,1) = "SK" + LangIDValue(15,0,2) = "-41B" + +' CURRENCIES_ESTONIAN + LangIDValue(16,0,0) = "et" + LangIDValue(16,0,1) = "ET" + LangIDValue(16,0,2) = "-425" + +' CURRENCIES_LATVIAN + LangIDValue(17,0,0) = "lv" + LangIDValue(17,0,1) = "LV" + LangIDValue(17,0,2) = "-426" + ' and Latgalian + LangIDValue(17,1,0) = "ltg" + LangIDValue(17,1,1) = "LV" + LangIDValue(17,1,2) = "-64B" + +' CURRENCIES_LITHUANIAN + LangIDValue(18,0,0) = "lt" + LangIDValue(18,0,1) = "LT" + LangIDValue(18,0,2) = "-427" + +End Sub + + + +Sub InitializeCurrencies() +Dim i as Integer + GoOn = True + + CurrValue(0,0) = sCurrPORTUGUESE + ' real conversion rate + CurrValue(0,1) = 200.482 + ' rounded conversion rate + CurrValue(0,2) = 200 + CurrValue(0,3) = "Esc." + CurrValue(0,4) = "Esc." + CurrValue(0,5) = "PTE" + + CurrValue(1,0) = sCurrDUTCH + ' real conversion rate + CurrValue(1,1) = 2.20371 + ' rounded conversion rate + CurrValue(1,2) = 2 + CurrValue(1,3) = "F" + CurrValue(1,4) = "fl" + CurrValue(1,5) = "NLG" + + CurrValue(2,0) = sCurrFRENCH + ' real conversion rate + CurrValue(2,1) = 6.55957 + ' rounded conversion rate + CurrValue(2,2) = 7 + CurrValue(2,3) = "F" + CurrValue(2,4) = "F" + CurrValue(2,5) = "FRF" + + CurrValue(3,0) = sCurrSPANISH + ' real conversion rate + CurrValue(3,1) = 166.386 + ' rounded conversion rate + CurrValue(3,2) = 170 + CurrValue(3,3) = "Pts" + CurrValue(3,4) = "Pts" + CurrValue(3,5) = "ESP" + + CurrValue(4,0) = sCurrITALIAN + ' real conversion rate + CurrValue(4,1) = 1936.27 + ' rounded conversion rate + CurrValue(4,2) = 2000 + CurrValue(4,3) = "L." + CurrValue(4,4) = "L." + CurrValue(4,5) = "ITL" + + CurrValue(5,0) = sCurrGERMAN + ' real conversion rate + CurrValue(5,1) = 1.95583 + ' rounded conversion rate + CurrValue(5,2) = 2 + CurrValue(5,3) = "DM" + CurrValue(5,4) = "DM" + CurrValue(5,5) = "DEM" + + CurrValue(6,0) = sCurrBELGIAN + ' real conversion rate + CurrValue(6,1) = 40.3399 + ' rounded conversion rate + CurrValue(6,2) = 40 + CurrValue(6,3) = "FB" + CurrValue(6,4) = "BF" + CurrValue(6,5) = "BEF" + + CurrValue(7,0) = sCurrIRISH + ' real conversion rate + CurrValue(7,1) = 0.787564 + ' rounded conversion rate + CurrValue(7,2) = 0.8 + CurrValue(7,3) = "IR£" + CurrValue(7,4) = "£" + CurrValue(7,5) = "IEP" + + CurrValue(8,0) = sCurrLUXEMBOURG + ' real conversion rate + CurrValue(8,1) = 40.3399 + ' rounded conversion rate + CurrValue(8,2) = 40 + CurrValue(8,3) = "F" + CurrValue(8,4) = "F" + CurrValue(8,5) = "LUF" + + CurrValue(9,0) = sCurrAUSTRIAN + ' real conversion rate + CurrValue(9,1) = 13.7603 + ' rounded conversion rate + CurrValue(9,2) = 15 + CurrValue(9,3) = "öS" + CurrValue(9,4) = "S" + CurrValue(9,5) = "ATS" + + CurrValue(10,0) = sCurrFINNISH + ' real conversion rate + CurrValue(10,1) = 5.94573 + ' rounded conversion rate + CurrValue(10,2) = 6 + CurrValue(10,3) = "mk" + CurrValue(10,4) = "mk" + CurrValue(10,5) = "FIM" + + CurrValue(11,0) = sCurrGREEK + ' real conversion rate + CurrValue(11,1) = 340.750 + ' rounded conversion rate + CurrValue(11,2) = 400 + CurrValue(11,3) = chr(916) & chr(961) & chr(967) + CurrValue(11,4) = chr(916) & chr(961) & chr(967) + CurrValue(11,5) = "GRD" + + CurrValue(12,0) = sCurrSLOVENIAN + ' real conversion rate + CurrValue(12,1) = 239.64 + ' rounded conversion rate + CurrValue(12,2) = 240 + CurrValue(12,3) = "SIT" + CurrValue(12,4) = "SIT" + CurrValue(12,5) = "SIT" + + CurrValue(13,0) = sCurrCYPRIOT + ' real conversion rate + CurrValue(13,1) = 0.585274 + ' rounded conversion rate + CurrValue(13,2) = 0.6 + CurrValue(13,3) = "£C" + CurrValue(13,4) = "£" + CurrValue(13,5) = "CYP" + + CurrValue(14,0) = sCurrMALTESE + ' real conversion rate + CurrValue(14,1) = 0.429300 + ' rounded conversion rate + CurrValue(14,2) = 0.4 + CurrValue(14,3) = chr(8356) + CurrValue(14,4) = "Lm" + CurrValue(14,5) = "MTL" + + CurrValue(15,0) = sCurrSLOVAK + ' real conversion rate + CurrValue(15,1) = 30.1260 + ' rounded conversion rate + CurrValue(15,2) = 30 + CurrValue(15,3) = "Sk" + CurrValue(15,4) = "Sk" + CurrValue(15,5) = "SKK" + + CurrValue(16,0) = sCurrESTONIAN + ' real conversion rate + CurrValue(16,1) = 15.6466 + ' rounded conversion rate + CurrValue(16,2) = 16 + CurrValue(16,3) = "kr" + CurrValue(16,4) = "kr" + CurrValue(16,5) = "EEK" + + CurrValue(17,0) = sCurrLATVIAN + ' real conversion rate + CurrValue(17,1) = 0.702804 + ' rounded conversion rate + CurrValue(17,2) = 0.7 + CurrValue(17,3) = "Ls" + CurrValue(17,4) = "Ls" + CurrValue(17,5) = "LVL" + + CurrValue(18,0) = sCurrLITHUANIAN + ' real conversion rate + CurrValue(18,1) = 3.45280 + ' rounded conversion rate + CurrValue(18,2) = 3.5 + CurrValue(18,3) = "Lt" + CurrValue(18,4) = "Lt" + CurrValue(18,5) = "LTL" + + i = -1 + CurrSymbolList(0) = "" + CurrSymbolList(1) = "" + InitializeCurrencyValues(CurrIndex) +End Sub + + +Sub InitializeControls() + If CurrIndex = -1 Then + If DialogModel.Step = 1 Then + EnableStep1DialogControls(True, False, False) + ElseIf DialogModel.Step = 2 Then + EnableStep2DialogControls(True) + End If + End If +End Sub + + +Sub InitializeConverter(oLocale, iDialogPage as Integer) +Dim Isthere as Boolean + bCancelProtection = False + bRangeListDefined = False + PWIndex = -1 + If iDialogPage = 1 Then + ToggleWindow(False) + sDocType = Tools.GetDocumentType(ThisComponent) + If sDocType = "sCalc" Then + bDocHasProtectedSheets = CheckSheetProtection(oSheets) + End If + oStatusline = ThisComponent.GetCurrentController.GetFrame.CreateStatusIndicator() + End If + DialogConvert = LoadDialog("Euro", "DlgConvert") + DialogModel = DialogConvert.Model + DialogPassword = LoadDialog("Euro", "DlgPassword") + PasswordModel = DialogPassword.Model + DialogModel.Step = iDialogPage + InitializeResources() + InitializeLanguages() + InitializeLocales(oLocale) + InitializeCurrencies() + InitializeControls() + BitmapDir = GetOfficeSubPath("Template", "../wizard/bitmap") + If BitmapDir = "" Then + Stop + End If + FillUpCurrencyListbox() + DialogModel.imgPreview.ImageUrl = BitmapDir & "euro_" & DialogModel.Step & ".png" + DialogConvert.Title = sMsgDLGTITLE + DialogModel.cmdGoOn.DefaultButton = True + If iDialogPage = 1 Then + ToggleWindow(True) + End If +End Sub + + +Sub InitializeCurrencyValues(CurrIndex) + If CurrIndex <> -1 Then + CurrLanguage = CurrValue(CurrIndex,0) + CurrFactor = CurrValue(CurrIndex,1) + CurrSymbolList(0) = CurrValue(CurrIndex,3) + CurrSymbolList(1) = CurrValue(CurrIndex,4) + CurrSymbolList(2) = CurrValue(CurrIndex,5) + End If +End Sub + + +Function InitializeLocales(oLocale) as Boolean +Dim i as Integer, n as Integer, m as Integer +Dim sLanguage as String, sCountry as String +Dim bTakeThisLocale as Boolean + sLanguage = oLocale.Language + sCountry = oLocale.Country + For n = 0 To SBCOUNTRYCOUNT - 1 + For m = 0 TO 1 + If DialogModel.Step = 2 Then + bTakeThisLocale = LangIDValue(n,m,0) = sLanguage + Else + bTakeThisLocale = LangIDValue(n,m,0) = sLanguage + End If + If bTakeThisLocale Then + CurrIndex = n + For i = 0 To 2 + CurExtension(i) = LangIDValue(CurrIndex,i,2) + Next i + InitializeLocales = True + Exit Function + End If + Next m + Next n + CurrIndex = -1 + InitializeLocales = False +End Function + diff --git a/wizards/source/euro/Protect.xba b/wizards/source/euro/Protect.xba new file mode 100644 index 000000000..4a9cac577 --- /dev/null +++ b/wizards/source/euro/Protect.xba @@ -0,0 +1,192 @@ + + + +REM ***** BASIC ***** +Option Explicit + +Public PWIndex as Integer + + +Function UnprotectSheetsWithPassWord(oSheets as Object, bDoUnProtect as Boolean) +Dim i as Integer +Dim MaxIndex as Integer +Dim iMsgResult as Integer + PWIndex = -1 + If bDocHasProtectedSheets Then + If Not bDoUnprotect Then + ' At First query if sheets shall generally be unprotected + iMsgResult = Msgbox(sMsgUNPROTECT,36,sMsgDLGTITLE) + bDoUnProtect = iMsgResult = 6 + End If + If bDoUnProtect Then + MaxIndex = oSheets.Count-1 + For i = 0 To MaxIndex + bDocHasProtectedSheets = Not UnprotectSheet(oSheets(i)) + If bDocHasProtectedSheets Then + ReprotectSheets() + Exit For + End If + Next i + If PWIndex = -1 Then + ReDim UnProtectList() as String + Else + ReDim Preserve UnProtectList(PWIndex) as String + End If + Else + Msgbox (sMsgSHEETSNOPROTECT, 64, sMsgDLGTITLE) + End If + End If + UnProtectSheetsWithPassword = bDocHasProtectedSheets +End Function + + +Function UnprotectSheet(oListSheet as Object) +Dim ListSheetName as String +Dim sStatustext as String +Dim i as Integer +Dim bOneSheetIsUnprotected as Boolean + i = -1 + ListSheetName = oListSheet.Name + If oListSheet.IsProtected Then + oListSheet.Unprotect("") + If oListSheet.IsProtected Then + ' Sheet is protected by a Password + bOneSheetIsUnProtected = UnprotectSheetWithDialog(oListSheet, ListSheetName) + UnProtectSheet() = bOneSheetIsUnProtected + Else + ' The Sheet could be unprotected without a password + AddSheettoUnprotectionlist(ListSheetName,"") + UnprotectSheet() = True + End If + Else + UnprotectSheet() = True + End If +End Function + + +Function UnprotectSheetWithDialog(oListSheet as Object, ListSheetName as String) as Boolean +Dim PWIsCorrect as Boolean +Dim QueryText as String + oDocument.CurrentController.SetActiveSheet(oListSheet) + QueryText = ReplaceString(sMsgPWPROTECT,"'" & ListSheetName & "'", "%1TableName%1") + '"Please insert the password to unprotect the sheet '" & ListSheetName'" + Do + ExecutePasswordDialog(QueryText) + If bCancelProtection Then + bCancelProtection = False + Msgbox (sMsgSHEETSNOPROTECT, 64, sMsgDLGTITLE) + UnprotectSheetWithDialog() = False + exit Function + End If + oListSheet.Unprotect(Password) + If oListSheet.IsProtected Then + PWIsCorrect = False + Msgbox (sMsgWRONGPW, 64, sMsgDLGTITLE) + Else + ' Sheet could be unprotected + AddSheettoUnprotectionlist(ListSheetName,Password) + PWIsCorrect = True + End If + Loop Until PWIsCorrect + UnprotectSheetWithDialog() = True +End Function + + +Sub ExecutePasswordDialog(QueryText as String) + With PasswordModel + .Title = QueryText + .hlnPassword.Label = sMsgPASSWORD + .cmdCancel.Label = sMsgCANCEL + .cmdHelp.Label = sHELP + .cmdGoOn.Label = sMsgOK + .cmdGoOn.DefaultButton = True + End With + DialogPassword.Execute +End Sub + +Sub ReadPassword() + Password = PasswordModel.txtPassword.Text + DialogPassword.EndExecute +End Sub + + +Sub RejectPassword() + bCancelProtection = True + DialogPassword.EndExecute +End Sub + + +' Reprotects the previously protected sheets +' The password information is stored in the List 'UnProtectList()' +Sub ReprotectSheets() +Dim i as Integer +Dim oProtectSheet as Object +Dim ProtectList() as String +Dim SheetName as String +Dim SheetPassword as String + If PWIndex > -1 Then + SetStatusLineText(sStsREPROTECT) + For i = 0 To PWIndex + ProtectList() = ArrayOutOfString(UnProtectList(i),";") + SheetName = ProtectList(0) + If Ubound(ProtectList()) > 0 Then + SheetPassWord = ProtectList(1) + Else + SheetPassword = "" + End If + oProtectSheet = oSheets.GetbyName(SheetName) + If Not oProtectSheet.IsProtected Then + oProtectSheet.Protect(SheetPassWord) + End If + Next i + SetStatusLineText("") + End If + PWIndex = -1 + ReDim UnProtectList() +End Sub + + +' Add a Sheet to the list of sheets that finally have to be +' unprotected +Sub AddSheettoUnprotectionlist(ListSheetName as String, Password as String) +Dim MaxIndex as Integer + MaxIndex = Ubound(UnProtectList()) + PWIndex = PWIndex + 1 + If PWIndex > MaxIndex Then + ReDim Preserve UnprotectList(MaxIndex + SBRANGEUBOUND) + End If + UnprotectList(PWIndex) = ListSheetName & ";" & Password +End Sub + + +Function CheckSheetProtection(oSheets as Object) as Boolean +Dim MaxIndex as Integer +Dim i as Integer +Dim bProtectedSheets as Boolean + bProtectedSheets = False + MaxIndex = oSheets.Count-1 + For i = 0 To MaxIndex + bProtectedSheets = oSheets(i).IsProtected + If bProtectedSheets Then + CheckSheetProtection() = True + Exit Function + End If + Next i + CheckSheetProtection() = False +End Function diff --git a/wizards/source/euro/Soft.xba b/wizards/source/euro/Soft.xba new file mode 100644 index 000000000..eed7bd030 --- /dev/null +++ b/wizards/source/euro/Soft.xba @@ -0,0 +1,256 @@ + + + +Option Explicit +REM ***** BASIC ***** + + +Sub CreateStyleEnumeration() + EmptySelection() + EmptyListbox(DialogModel.lstSelection) + CurSheetName = oDocument.CurrentController.GetActiveSheet.Name + MakeStyleEnumeration(False) + DialogModel.lblSelection.Label = sTEMPLATES +End Sub + + +Sub MakeStyleEnumeration(bAddToListbox as Boolean) +Dim m as integer +Dim aStyleFormat as Object +Dim Stylename as String + StyleIndex = -1 + oStyles = oDocument.StyleFamilies.GetbyIndex(0) + For m = 0 To oStyles.count-1 + oStyle = oStyles.GetbyIndex(m) + StyleName = oStyle.Name + If CheckFormatType(oStyle) Then + If Not bAddToListBox Then + AddSingleItemToListbox(DialogModel.lstSelection, Stylename) + Else + SwitchNumberFormat(ostyle, oFormats, sEuroSign) + End If + StyleIndex = StyleIndex + 1 + If StyleIndex > Ubound(StyleRangeAssignMentList()) Then + Redim Preserve StyleRangeAssignmentList(StyleIndex) + End If + StyleRangeAssignmentList(StyleIndex) = "<STYLENAME>" & Stylename & "</STYLENAME>" & _ + "<DEFINED>FALSE</DEFINED>" & "<RANGES></RANGES>" &_ + "<CELLCOUNT>0</CELLCOUNT>" &_ + "<SELECTED>FALSE</SELECTED>" + End If + Next m + If StyleIndex > -1 Then + Redim Preserve StyleRangeAssignmentList(StyleIndex) + Else + ReDim StyleRangeAssignmentList() + End If +End Sub + + +Sub AssignRangestoStyle(StyleList(), SelList()) +Dim i as Integer +Dim n as integer +Dim LastIndex as Integer +Dim CurStyleName as String +Dim AssignString as String + LastIndex = Ubound(StyleList()) + StatusValue = 0 + SetStatusLineText(sStsRELRANGES) + For i = 0 To LastIndex + CurStyleName = StyleList(i) + n = PartStringInArray(StyleRangeAssignmentList(), CurStyleName, 0) + AssignString = StyleRangeAssignmentlist(n) + If IndexInArray(CurStyleName, SelList()) <> -1 Then + ' Style is selected + If FindPartString(AssignString, "<DEFINED>", "</DEFINED>", 1) = "FALSE" Then + AssignString = ReplaceString(AssignString, "<SELECTED>TRUE</SELECTED>", "<SELECTED>FALSE</SELECTED>") + AssignCellFormatRanges(n, AssignString, CurStyleName) + End If + Else + ' Style is not selected + If FindPartString(AssignString, "<SELECTED>", "</SELECTED>", 1) = "FALSE" Then + DeselectStyle(CurStyleName, n) + End If + End If + IncreaseStatusvalue(SBRELGET/(LastIndex+1)) + Next i +End Sub + + +Sub AssignCellFormatRanges(n as Integer, AssignString as String, CurStyleName as String) +Dim oRanges() as Object +Dim oRange as Object +Dim oRangeAddress +Dim oSheet as Object +Dim StyleCellCount as Long +Dim i as Integer +Dim MaxIndex as Integer +Dim RangeString as String +Dim SheetName as String +Dim RangeName as String +Dim CellCountString as String + StyleCellCount = 0 + RangeString = "<RANGES>" + MaxIndex = oSheets.Count-1 + For i = 0 To MaxIndex + oSheet = oSheets(i) + SheetName = oSheet.Name + oRanges = osheet.CellFormatRanges.CreateEnumeration + While oRanges.hasMoreElements + oRange = oRanges.NextElement + If oRange.getPropertyState("NumberFormat") = 1 Then + If oRange.CellStyle = CurStyleName Then + oRangeAddress = oRange.RangeAddress + RangeName = RetrieveRangeNamefromAddress(oRange) + RangeString = RangeString & RangeName & "," + StyleCellCount = StyleCellCount + CountRangeCells(oRange) + End If + End If + Wend + Next i + If StyleCellCount > 0 Then + TotCellCount = TotCellCount + StyleCellCount + RangeString = RTrimStr(RangeString,",") + RangeString = RangeString & "</RANGES>" + CellCountString = "<CELLCOUNT>" & StyleCellCount & "</CELLCOUNT" + AssignString = ReplaceString(AssignString, RangeString,"<RANGES></RANGES>") + AssignString = ReplaceString(AssignString, CellCountString,"<CELLCOUNT>0</CELLCOUNT>") + End If + AssignString = ReplaceString(AssignString, "<DEFINED>TRUE</DEFINED>", "<DEFINED>FALSE</DEFINED>") + StyleRangeAssignmentList(n) = AssignString +End Sub + + +' deletes a styletemplate from the Collection that selects the ranges +Sub DeselectStyle(DeSelStyleName as String, n as Integer) +Dim i as Integer +Dim RangeName as String +Dim SelectString as String +Dim AssignString as String +Dim StyleRangeList() as String +Dim MaxIndex as Integer + SelectString ="<SELECTED>FALSE</SELECTED>" + AssignString = StyleRangeAssignmentList(n) + RangeString = FindPartString(AssignString,"<RANGES>","</RANGES>",1) + StyleRangeList() = ArrayoutofString(RangeString,",") + MaxIndex = Ubound(StyleRangeList()) + For i = 0 To MaxIndex + RangeName = StyleRangeList(i) + If oSelRanges.HasbyName(RangeName) Then + oSelRanges.RemovebyName(RangeName) + End If + Next i + AssignString = ReplaceString(AssignString, "<SELECTED>FALSE</SELECTED>", "<SELECTED>TRUE</SELECTED>") + StyleRangeAssignmentList(n) = AssignString +End Sub + + +Function RetrieveRangeNamefromAddress(oRange as Object) as String +Dim Rangename as String +Dim oAddressRanges as Object + oAddressRanges = oDocument.createInstance("com.sun.star.sheet.SheetCellRanges") + oAddressRanges.InsertbyName("",oRange) + Rangename = oAddressRanges.RangeAddressesasString +' Msgbox "Adresse: " & oRangeAddress.StartColumn & " ; " & oRangeAddress.EndColumn & " ; " & oRangeAddress.StartRow & " ; " & oRangeAddress.EndRow & chr(13) & RangeName +' oAddressRanges.RemovebyName(RangeName) + RetrieveRangeNamefromAddress = Rangename +End Function + + +' creates a sheet object from an according sectionname +Function RetrieveSheetoutofRangeName(TableText as String) +Dim DescriptionList() as String +Dim SheetName as String +Dim MaxIndex as integer + ' find out in which sheet the range is + DescriptionList() = ArrayOutofString(TableText,".",MaxIndex) + SheetName = DescriptionList(0) + SheetName = DeleteStr(SheetName,"'") + ' set the viewcursor on this sheet + RetrieveSheetoutofRangeName = oSheets.GetbyName(SheetName) +End Function + + +' creates a rangeobject from an according rangename +Function RetrieveRangeoutofRangeName(TableText as String) + oSheet = RetrieveSheetoutofRangeName(TableText) + oRange = oSheet.GetCellRangebyName(TableText) + RetrieveRangeoutofRangeName = oRange +End Function + + +Sub ConvertTheSoftWay(StyleList(), bDeSelect as Boolean) +Dim i as Integer +Dim l as Integer +Dim s as Integer +Dim n as Integer +Dim CurStyleName as String +Dim RangeName as String +Dim OldStatusValue as Integer +Dim LastIndex as Integer +Dim oSelListbox as Object +Dim StyleRangeList() as String +Dim MaxIndex as Integer + oSelListbox = DialogConvert.GetControl("lstSelection") + LastIndex = Ubound(StyleList()) + OldStatusValue = StatusValue + For i = 0 To LastIndex + CurStyleName = StyleList(i) + oStyle = oStyles.GetbyName(CurStyleName) + StyleRangeList() = GetAssignedRanges(CurStyleName, n) + MaxIndex = Ubound(StyleRangeList()) + For s = 0 To MaxIndex + RangeName = StyleRangeList(s) + oRange = RetrieveRangeoutofRangeName(RangeName) + If oRange.getPropertyState("NumberFormat") = 1 Then + ' Range is hard formatted + ConvertCellCurrencies(oRange) + CurCellCount = CountRangeCells(oRange) + End If + IncreaseStatusvalue((CurCellCount/TotCellCount)*(95-OldStatusValue)) + If bDeSelect Then + ' Note: On Problems see Bug #73157 + If oSelRanges.HasbyName(RangeName) Then + oSelRanges.RemovebyName(RangeName) + oDocument.CurrentController.Select(oSelRanges) + End If + End If + Next s + SwitchNumberFormat(ostyle, oFormats, sEuroSign) + StyleRangeAssignmentList(n) = "" + l = GetItemPos(oSelListBox.Model, CurStyleName) + oSelListbox.RemoveItems(l,1) + Next +End Sub + + +Function GetAssignedRanges(CurStyleName as String, n as Integer) +Dim StyleRangeList() as String +Dim RangeString as String +Dim AssignString as String + n = PartStringInArray(StyleRangeAssignmentList(), CurStyleName, 0) + If n <> -1 Then + AssignString = StyleRangeAssignmentList(n) + RangeString = FindPartString(AssignString,"<RANGES>", "</RANGES>",1) + If RangeString <> "" Then + StyleRangeList() = ArrayoutofString(RangeString,",") + End If + End If + GetAssignedRanges() = StyleRangeList() +End Function \ No newline at end of file diff --git a/wizards/source/euro/Writer.xba b/wizards/source/euro/Writer.xba new file mode 100644 index 000000000..bf89135bc --- /dev/null +++ b/wizards/source/euro/Writer.xba @@ -0,0 +1,89 @@ + + + +REM ***** BASIC ***** + + +Sub ConvertWriterTables() +Dim CellString as String +Dim oParagraphs as Object +Dim oPara as Object +Dim i as integer +Dim sCellNames() +Dim oCell as Object + oParagraphs = oDocument.Text.CreateEnumeration + While oParagraphs.HasMoreElements + oPara = oParagraphs.NextElement + If NOT oPara.supportsService("com.sun.star.text.Paragraph") Then + ' Note: As cells might be split or merged + ' you cannot refer to them via their indices + sCellNames = oPara.CellNames + For i = 0 To Ubound(sCellNames) + If sCellNames(i) <> "" Then + oCell = oPara.getCellByName(sCellNames(i)) + If CheckFormatType(oCell) Then + SwitchNumberFormat(oCell, oFormats, sEuroSign) + ModifyObjectValuewithCurrFactor(oCell) + End If + End If + Next + End If + Wend +End Sub + + +Sub ModifyObjectValuewithCurrFactor(oDocObject as Object) + oDocObjectValue = oDocObject.Value + oDocObject.Value = oDocObjectValue/CurrFactor +End Sub + + +Sub ConvertTextFields() +Dim oTextFields as Object +Dim oTextField as Object +Dim FieldValue +Dim oDocObjectValue as double +Dim InstanceNames(500) as String +Dim CurInstanceName as String +Dim MaxIndex as Integer + MaxIndex = 0 + oTextfields = oDocument.getTextfields.CreateEnumeration + While oTextFields.hasmoreElements + oTextField = oTextFields.NextElement + If oTextField.PropertySetInfo.HasPropertybyName("NumberFormat") Then + If CheckFormatType(oTextField) Then + If oTextField.PropertySetInfo.HasPropertybyName("Value") Then + If Not oTextField.SupportsService("com.sun.star.text.TextField.GetExpression") Then + oTextField.Content = CStr(Round(oTextField.Value/CurrFactor,2)) + End If + ElseIf oTextField.TextFieldMaster.PropertySetInfo.HasPropertyByName("Value") Then + CurInstanceName = oTextField.TextFieldMaster.InstanceName + If Not FieldInArray(InstanceNames(), MaxIndex, CurInstanceName) Then + oTextField.TextFieldMaster.Content = CStr(Round(oTextField.TextFieldMaster.Value/CurrFactor,2)) + InstanceNames(MaxIndex) = CurInstanceName + MaxIndex = MaxIndex + 1 + End If + End If + SwitchNumberFormat(oTextField, oFormats, sEuroSign) + End If + End If + Wend + oDocument.GetTextFields.refresh() +End Sub + \ No newline at end of file diff --git a/wizards/source/euro/dialog.xlb b/wizards/source/euro/dialog.xlb new file mode 100644 index 000000000..c461ce54f --- /dev/null +++ b/wizards/source/euro/dialog.xlb @@ -0,0 +1,6 @@ + + + + + + diff --git a/wizards/source/euro/script.xlb b/wizards/source/euro/script.xlb new file mode 100644 index 000000000..1bc4927c2 --- /dev/null +++ b/wizards/source/euro/script.xlb @@ -0,0 +1,12 @@ + + + + + + + + + + + + diff --git a/wizards/source/formwizard/DBMeta.xba b/wizards/source/formwizard/DBMeta.xba new file mode 100644 index 000000000..b0fa20b7a --- /dev/null +++ b/wizards/source/formwizard/DBMeta.xba @@ -0,0 +1,347 @@ + + + +REM ***** BASIC ***** +Option Explicit + + +Public iCommandTypes() as Integer +Public CurCommandType as Integer +Public oDataSource as Object +Public bEnableBinaryOptionGroup as Boolean +'Public bSelectContent as Boolean + + +Function GetDatabaseNames(baddFirstListItem as Boolean) +Dim sDatabaseList() + If oDBContext.HasElements Then + Dim LocDBList() as String + Dim MaxIndex as Integer + Dim i as Integer + LocDBList = oDBContext.ElementNames() + MaxIndex = Ubound(LocDBList()) + If baddfirstListItem Then + ReDim Preserve sDatabaseList(MaxIndex + 1) + sDatabaseList(0) = sSelectDatasource + a = 1 + Else + ReDim Preserve sDatabaseList(MaxIndex) + a = 0 + End If + For i = 0 To MaxIndex + sDatabaseList(a) = oDBContext.ElementNames(i) + a = a + 1 + Next i + End If + GetDatabaseNames() = sDatabaseList() +End Function + + +Sub GetSelectedDBMetaData(sDBName as String) +Dim OldsDBname as String +Dim DBIndex as Integer +Dim LocList() as String +' If bStartUp Then +' bStartUp = false +' Exit Sub +' End Sub + ToggleDatabasePage(False) + With DialogModel + If GetConnection(sDBName) Then + If GetDBMetaData() Then + LocList() = AddListToList(Array(sSelectDBTable), TableNames()) + .lstTables.StringItemList() = AddListToList(LocList(), QueryNames()) +' bSelectContent = True + .lstTables.SelectedItems() = Array(0) + iCommandTypes() = CreateCommandTypeList() + EmptyFieldsListboxes() + End If + End If + bEnableBinaryOptionGroup = False + .lstTables.Enabled = True + .lblTables.Enabled = True +' Else +' DialogModel.lstTables.StringItemList = Array(sSelectDBTable) +' EmptyFieldsListboxes() +' End If + ToggleDatabasePage(True) + End With +End Sub + + +Function GetConnection(sDBName as String) +Dim oInteractionHandler as Object +Dim bExitLoop as Boolean +Dim bGetConnection as Boolean +Dim iMsg as Integer +Dim Nulllist() + If Not IsNull(oDBConnection) Then + oDBConnection.Dispose() + End If + oDataSource = oDBContext.GetByName(sDBName) +' If Not oDBContext.hasbyName(sDBName) Then +' GetConnection() = False +' Exit Function +' End If + If Not oDataSource.IsPasswordRequired Then + oDBConnection = oDBContext.GetByName(sDBName).GetConnection("","") + GetConnection() = True + Else + oInteractionHandler = createUnoService("com.sun.star.task.InteractionHandler") + oDataSource = oDBContext.GetByName(sDBName) + On Local Error Goto NOCONNECTION + Do + bExitLoop = True + oDBConnection = oDataSource.ConnectWithCompletion(oInteractionHandler) + NOCONNECTION: + bGetConnection = Err = 0 + If bGetConnection Then + bGetConnection = Not IsNull(oDBConnection) + If Not bGetConnection Then + Exit Do + End If + End If + If Not bGetConnection Then + iMsg = Msgbox (sMsgNoConnection,32 + 2, sMsgWizardName) + bExitLoop = iMsg = SBCANCEL + Resume CLERROR + CLERROR: + End If + Loop Until bExitLoop + On Local Error Goto 0 + If Not bGetConnection Then + DialogModel.lstTables.StringItemList() = Array(sSelectDBTable) + DialogModel.lstFields.StringItemList() = NullList() + DialogModel.lstSelFields.StringItemList() = NullList() + End If + GetConnection() = bGetConnection + End If +End Function + + +Function GetDBMetaData() + If oDBContext.HasElements Then + Tablenames() = oDBConnection.Tables.ElementNames() + Querynames() = oDBConnection.Queries.ElementNames() + GetDBMetaData = True + Else + MsgBox(sMsgErrNoDatabase, 64, sMsgWizardName) + GetDBMetaData = False + End If +End Function + + +Sub GetTableMetaData() +Dim iType as Long +Dim m as Integer +Dim Found as Boolean +Dim i as Integer +Dim sFieldName as String +Dim n as Integer +Dim WidthIndex as Integer +Dim oField as Object + MaxIndex = Ubound(DialogModel.lstSelFields.StringItemList()) + Dim ColumnMap(MaxIndex)as Integer + FieldNames() = DialogModel.lstSelFields.StringItemList() + ' Build a structure which maps the position of a selected field (within the selection) to the column position within + ' the table. So we ensure that the controls are placed in the same order the according fields are selected. + For i = 0 To Ubound(FieldNames()) + sFieldName = FieldNames(i) + Found = False + n = 0 + While (n< MaxIndex And (Not Found)) + If (FieldNames(n) = sFieldName) Then + Found = True + ColumnMap(n) = i + End If + n = n + 1 + Wend + Next i + For n = 0 to MaxIndex + sFieldname = FieldNames(n) + oField = oColumns.GetByName(sFieldName) + iType = oField.Type + FieldMetaValues(n,0) = oField.Type + FieldMetaValues(n,1) = AssignFieldLength(oField.Precision) + FieldMetaValues(n,2) = GetValueoutofList(iType, WidthList(),1, WidthIndex) + FieldMetaValues(n,3) = WidthList(WidthIndex,3) + FieldMetaValues(n,4) = oField.FormatKey + FieldMetaValues(n,5) = oField.DefaultValue + FieldMetaValues(n,6) = oField.IsCurrency + FieldMetaValues(n,7) = oField.Scale +' If oField.Description <> "" Then +'' Todo: What's wrong with this line? +' Msgbox oField.Helptext +' End If + FieldMetaValues(n,8) = oField.Description + Next + ReDim oDBShapeList(MaxIndex) as Object + ReDim oTCShapeList(MaxIndex) as Object + ReDim oDBModelList(MaxIndex) as Object + ReDim oGroupShapeList(MaxIndex) as Object +End Sub + + +Function GetSpecificFieldNames() as Integer +Dim n as Integer +Dim m as Integer +Dim s as Integer +Dim iType as Integer +Dim oField as Object +Dim MaxIndex as Integer +Dim EmptyList() + If Ubound(DialogModel.lstTables.StringItemList()) > -1 Then + FieldNames() = oColumns.GetElementNames() + MaxIndex = Ubound(FieldNames()) + If MaxIndex <> -1 Then + Dim ResultFieldNames(MaxIndex) + ReDim ImgFieldNames(MaxIndex) + m = 0 + For n = 0 To MaxIndex + oField = oColumns.GetByName(FieldNames(n)) + iType = oField.Type + If GetIndexInMultiArray(WidthList(), iType, 0) <> -1 Then + ResultFieldNames(m) = FieldNames(n) + m = m + 1 + End If + If GetIndexInMultiArray(ImgWidthList(), iType, 0) <> -1 Then + ImgFieldNames(s) = FieldNames(n) + s = s + 1 + End If + Next n + If s <> 0 Then + Redim Preserve ImgFieldNames(s-1) + bEnableBinaryOptionGroup = True + Else + bEnableBinaryOptionGroup = False + End If + If (DialogModel.optBinariesasGraphics.State = 1) And (s <> 0) Then + ResultFieldNames() = AddListToList(ResultFieldNames(), ImgFieldNames()) + Else + Redim Preserve ResultFieldNames(m-1) + End If + FieldNames() = ResultFieldNames() + DialogModel.lstFields.StringItemList = FieldNames() + InitializeListboxProcedures(DialogModel, DialogModel.lstFields, DialogModel.lstSelFields) + End If + GetSpecificFieldNames = MaxIndex + Else + GetSpecificFieldNames = -1 + End If +End Function + + +Sub CreateDBForm() + If oDrawPage.Forms.Count = 0 Then + oDBForm = oDocument.CreateInstance("com.sun.star.form.component.Form") + oDrawpage.Forms.InsertByIndex (0, oDBForm) + Else + oDBForm = oDrawPage.Forms.GetByIndex(0) + End If + oDBForm.Name = "Standard" + oDBForm.DataSourceName = sDBName + oDBForm.Command = TableName + oDBForm.CommandType = CurCommandType +End Sub + + +Sub AddOrRemoveBinaryFieldsToWidthList() +Dim LocWidthList() +Dim MaxIndex as Integer +Dim OldMaxIndex as Integer +Dim s as Integer +Dim n as Integer +Dim m as Integer + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + If DialogModel.optBinariesasGraphics.State = 1 Then + OldMaxIndex = Ubound(WidthList(),1) + If OldMaxIndex = 15 Then + MaxIndex = Ubound(WidthList(),1) + Ubound(ImgWidthList(),1) + 1 + ReDim Preserve WidthList(MaxIndex,4) + s = 0 + For n = OldMaxIndex + 1 To MaxIndex + For m = 0 To 3 + WidthList(n,m) = ImgWidthList(s,m) + Next m + s = s + 1 + Next n + MergeList(DialogModel.lstFields, ImgFieldNames()) + End If + Else + ReDim Preserve WidthList(15, 4) + RemoveListItems(DialogModel.lstFields(), DialogModel.lstSelFields(), ImgFieldNames()) + End If + DialogModel.lstSelFields.Tag = True +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If +End Sub + + +Function CreateCommandTypeList() +Dim MaxTableIndex as Integer +Dim MaxQueryIndex as Integer +Dim MaxIndex as Integer +Dim i as Integer +Dim a as Integer + MaxTableIndex = Ubound(TableNames()) + MaxQueryIndex = Ubound(QueryNames()) + MaxIndex = MaxTableIndex + MaxQueryIndex + 1 + If MaxIndex > -1 Then + Dim LocCommandTypes(MaxIndex) as Integer + For i = 0 To MaxTableIndex + LocCommandTypes(i) = com.sun.star.sdb.CommandType.TABLE + Next i + a = i + For i = 0 To MaxQueryIndex + LocCommandTypes(a) = com.sun.star.sdb.CommandType.QUERY + a = a + 1 + Next i + End If + CreateCommandTypeList() = LocCommandTypes() +End Function + + +Sub GetCurrentMetaValues(Index as Integer) + CurFieldType = FieldMetaValues(Index,0) + CurFieldLength = FieldMetaValues(Index,1) + CurControlType = FieldMetaValues(Index,2) + CurControlName = FieldMetaValues(Index,3) + CurFormatKey = FieldMetaValues(Index,4) + CurDefaultValue = FieldMetaValues(Index,5) + CurIsCurrency = FieldMetaValues(Index,6) + CurScale = FieldMetaValues(Index,7) + CurHelpText = FieldMetaValues(Index,8) + CurFieldName = FieldNames(Index) +End Sub + + +Function AssignFieldLength(FieldLength as Long) as Integer + If FieldLength >= 65535 Then + AssignFieldLength() = -1 + Else + AssignFieldLength() = FieldLength + End If +End Function + diff --git a/wizards/source/formwizard/DlgFormDB.xdl b/wizards/source/formwizard/DlgFormDB.xdl new file mode 100644 index 000000000..debb8bf38 --- /dev/null +++ b/wizards/source/formwizard/DlgFormDB.xdl @@ -0,0 +1,111 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/formwizard/FormWizard.xba b/wizards/source/formwizard/FormWizard.xba new file mode 100644 index 000000000..68a80ff88 --- /dev/null +++ b/wizards/source/formwizard/FormWizard.xba @@ -0,0 +1,440 @@ + + + +Option Explicit + +Public DocumentName as String +Public FormPath as String +Public WizardPath as String +Public WorkPath as String +Public TempPath as String +Public TexturePath as String +Public sQueryName as String +Public oDBConnection as Object +Public bWithBackGraphic as Boolean +Public bNeedFieldRefresh as Boolean +Public oDBForm as Object +Public oColumns() as Object +Public sDatabaseList() as String +Public TableNames() as String +Public QueryNames() as String +Public FieldNames() as String +Public ImgFieldNames() as String +Public oDBContext as Object +Public oUcb as Object +Public oDocInfo as Object +Public WidthList(15,3) +Public ImgWidthList(3,3) +Public sDBName as String +Public Tablename as String +Public Const SBSIZETEXT = "The quick brown fox jumps over the lazy dog. The quick brown fox jumps over the lazy dog." +Public bDisposeDoc as Boolean +Public bDebug as Boolean +'Public bStartUp as Boolean +Public bConnectionIsovergiven as Boolean +Public FormName As String +Public sFormUrl as String +Public oFormDocuments + + +' The macro can be called in 4 possible scenarios: +' Scenario 1. No parameters at given +' Scenario 2: Only Datasourcename is given, but no connection and no Content +' Scenario 3: a data source and a connection are given +' Scenario 4: all parameters (data source name, connection, object type and object) are given + +Sub Main() +Dim oLocDBContext as Object +Dim oLocConnection as Object + +' Scenario 1. No parameters at given + MainWithDefault() + +' Scenario 2: Only Datasourcename is given, but no connection and no Content +' MainWithDefault("Bibliography") + +' Scenario 3: a data source and a connection are given +' oLocDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") +' oLocConnection = oLocDBContext.GetByName("Bibliography").GetConnection("","") +' MainWithDefault("Bibliography", oLocConnection) + +' Scenario 4: all parameters (data source name, connection, object type and object) are given +' oLocDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") +' oLocConnection = oLocDBContext.GetByName("Bibliography").GetConnection("","") +' MainWithDefault("Bibliography", oLocConnection, com.sun.star.sdb.CommandType.TABLE, "biblio") +End Sub + + +Sub MainWithDefault(Optional DatasourceName as String, Optional oConnection as Object, Optional CommandType as Integer, Optional sContent as String) +Dim i as Integer +Dim SelCount as Integer +Dim RetValue as Integer +Dim SelList(0) as Integer +Dim LocList() as String + SelList(0) = 0 + BasicLibraries.LoadLibrary("Tools") + bDebug = False + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + OpenFormDocument() + CurArrangement = 0 + bControlsareCreated = False + bEnableBinaryOptionGroup = False + bDisposeDoc = True + MaxIndex = -1 + If Not InitResources("Formwizard") Then + Exit Sub + End If + oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + If GetFormWizardPaths() = False Then + Exit Sub + End If + oDocument.GetCurrentController().Frame.ComponentWindow.Enable = False + oProgressBar.Value = 10 + LoadLanguage() + oProgressBar.Value = 20 + InitializeWidthList() + oProgressBar.Value = 30 + Styles() = getListBoxArrays(oUcb, "/stl") + CurIndex = GetCurIndex(DialogModel, Styles(), 2) + oProgressBar.Value = 40 + ConfigurePageStyle() + oProgressBar.Value = 50 + InitializeLabelValues() + bNeedFieldRefresh = True + SetDialogLanguage() +' bStartUp = true + With DialogModel + .cmdBack.Enabled = False + .cmdGoOn.Enabled = False + .lblTables.Enabled = False + .lstSelFields.Tag = False + .Step = 1 + End With + oProgressBar.Value = 60 + bConnectionIsovergiven = Not IsMissing(oConnection) + If Not IsMissing(DataSourceName) Then + sDBName = DataSourceName + If Not IsMissing(oConnection) Then + ' Scenario 3: a data source and a connection are given + Set oDBConnection = oConnection + oDataSource = oDBContext.GetByName(DataSourceName) + DialogModel.lstTables.Enabled = True + DialogModel.lblTables.Enabled = True + If GetDBMetaData() Then + LocList() = AddListToList(TableNames(), QueryNames()) + iCommandTypes = CreateCommandTypeList() + If Not IsMissing(sContent) Then + ' Scenario 4: all parameters (data source name, connection, object type and object) are given + DialogModel.lstTables.StringItemList() = LocList() + iCommandTypes() = CreateCommandTypeList() + SelCount = CountItemsInArray(DialogModel.lstTables.StringItemList(), sContent) + If SelCount = 1 Then + DlgFormDB.GetControl("lstTables").SelectItem(sContent, True) + Else + If CommandType = com.sun.star.sdb.CommandType.QUERY Then + SelIndex = IndexInArray(sContent, QueryNames()) + DlgFormDB.GetControl("lstTables").SelectItemPos(SelIndex, True) + ElseIf CommandType = com.sun.star.sdb.CommandType.TABLE Then + SelIndex = IndexInArray(sContent, TableNames()) + DlgFormDB.GetControl("lstTables").SelectItemPos(Ubound(QueryNames()+1 + SelIndex, True)) + End If + End If + CurCommandType = CommandType + FillUpFieldsListbox(False) + Else + LocList() = AddListToList(Array(sSelectDBTable), LocList()) + DialogModel.lstTables.StringItemList() = LocList() +' bSelectContent = True + DialogModel.lstTables.SelectedItems() = Array(0) + + End If + End If + Else + ' Scenario 2: Only Datasourcename is given, but no connection and no Content + GetSelectedDBMetaData(sDBName) + End If + Else + ' Scenario 1: No parameters are given + ToggleListboxControls(DialogModel, False) + End If + oProgressBar.Value = 80 + bWithBackGraphic = LoadNewStyles(oDocument, DialogModel, CurIndex, Styles(CurIndex, 8), Styles(), TexturePath) + DlgFormDB.Title = WizardTitle(1) + DialogModel.lstStyles.StringItemList() = ArrayfromMultiArray(Styles, 1) + DialogModel.lstStyles.SelectedItems() = SelList() + ControlCaptionsToStandardLayout() + oDocument.GetCurrentController().Frame.ComponentWindow.Enable = True + oProgressBar.Value = 90 + DialogModel.imgTheme.ImageURL = FormPath & "FormWizard_1.png" + DialogModel.imgTheme.BackGroundColor = RGB(0,60,126) + ToggleDatabasePage(True) + oProgressBar.Value = 100 + DlgFormDB.GetControl("lstTables").SetFocus() + oProgressbar.End + RetValue = DlgFormDB.Execute() + DlgFormDB.Dispose() + If bDisposeDoc Then + Dim aPropertyValues(2) as new com.sun.star.beans.PropertyValue + oFormDocuments = oDataSource.getFormDocuments() + DlgFormDB.Dispose() + oDocument.dispose() + Dim bLinkExists as Boolean + i = 1 + Dim FormBaseName as String + FormBaseName = FormName + Do + bLinkExists = oFormDocuments.HasbyHierarchicalName(FormName) + If bLinkExists Then + i = i + 1 + FormName = FormBaseName & "_" & i + End If + Loop Until Not bLinkExists + aPropertyValues(0).Name = "Name" + aPropertyValues(0).Value = FormName + aPropertyValues(1).Name = "Parent" + aPropertyValues(1).Value = oFormDocuments() + aPropertyValues(2).Name = "URL" + aPropertyValues(2).Value = sFormUrl + Dim oDBDocument + oDBDocument = oFormDocuments.createInstanceWithArguments("com.sun.star.sdb.DocumentDefinition", aPropertyValues()) + oFormDocuments.insertbyName(FormName, oDBDocument) + ElseIf RetValue = 0 Then + RemoveNirwanaShapes() + End If + If ((Not IsNull(oDBConnection)) And (Not bConnectionIsovergiven)) Then + oDBConnection.Dispose() + End If +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If +End Sub + + +Sub FormGetFields() +Dim i as Integer +' If bSelectContent Then +' bSelectContent = False +' Exit Sub +' End If + DeleteFirstListBoxEntry("lstTables", sSelectDBTable) + ToggleDatabasePage(False) + FillUpFieldsListbox(True) + ToggleDatabasePage(True) +End Sub + + +Sub FillUpFieldsListbox(bGetCommandType as Boolean) +Dim SelIndex as Integer +Dim QueryIndex as Integer + If Not bDebug Then + On Local Error GoTo NOFIELDS + End If + SelIndex = DlgFormDB.GetControl("lstTables").getSelectedItemPos() '.SelectedItems()) + If SelIndex > -1 Then + If bGetCommandType Then + CurCommandType = iCommandTypes(SelIndex) + End If + If CurCommandType = com.sun.star.sdb.CommandType.QUERY Then + QueryIndex = SelIndex - Ubound(Tablenames()) - 1 + Tablename = QueryNames(QueryIndex) + oColumns = oDBConnection.Queries.GetByName(TableName).Columns + Else + Tablename = Tablenames(SelIndex) + oColumns = oDBConnection.Tables.GetByName(Tablename).Columns + End If + If GetSpecificFieldNames() <> -1 Then + ToggleListboxControls(DialogModel, True) + Exit Sub + End If + End If + EmptyFieldsListboxes() +NOFIELDS: + If Err <> 0 Then + MsgBox sMsgErrCouldNotOpenObject, 16, sMsgWizardName + End If +End Sub + + +Sub PreviousStep() + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + With DialogModel + .Step = 1 + .cmdBack.Enabled = False + .cmdGoOn.Enabled = True + .lstSelFields.Tag = Not bControlsareCreated + .cmdGoOn.Label = sGoOn + .imgTheme.ImageUrl = FormPath & "FormWizard_1.png" + End With + FormSetMoveRights() +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If +End Sub + + +Sub NextStep() + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + Select Case DialogModel.Step + Case 1 + bControlsAreCreated = Not (cBool(DialogModel.lstSelFields.Tag)) + If Not bControlsAreCreated Then + GetTableMetaData() + CreateDBForm() + RemoveShapes() + InitializeLayoutSettings() + oDBForm.Load + End If + DialogModel.cmdGoOn.Label = sReady + DialogModel.cmdBack.Enabled = True + DialogModel.Step = 2 + bDisposeDoc = False + Case 2 + StoreForm() + DlgFormDB.EndExecute() + exit Sub + End Select + DialogModel.imgTheme.ImageUrl = FormPath & "FormWizard_" & DialogModel.Step & ".png" + DlgFormDB.Title = WizardTitle(DialogModel.Step) +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If +End Sub + + +Sub InitializeLayoutSettings() + SwitchArrangementButtons(cTabled) + SwitchAlignMode(SBALIGNLEFT) + SwitchBorderMode(SB3DBORDER) + ToggleBorderGroup(bControlsAreCreated) + ToggleAlignGroup(bControlsAreCreated) + ArrangeControls() + If OldAlignMode <> 0 Then + DlgFormDB.GetControl("optAlign2").Model.State = 0 + End If +End Sub + + +Sub ToggleDatabasePage(bDoEnable as Boolean) + With DialogModel + .cmdBack.Enabled = False + .cmdHelp.Enabled = bDoEnable + .cmdGoOn.Enabled = Ubound(DialogModel.lstSelFields.StringItemList()) <> -1 + .hlnBinaries.Enabled = ((bDoEnable = True) And (bEnableBinaryOptionGroup = True)) + .optIgnoreBinaries.Enabled = ((bDoEnable = True) And (bEnableBinaryOptionGroup = True)) + .optBinariesasGraphics.Enabled = ((bDoEnable = True) And (bEnableBinaryOptionGroup = True)) + End With +End Sub + + +' This Sub is called from the Procedure "StoreDocument" in the "Tools" Library +Sub CommitLastDocumentChanges(sTargetPath as String) +Dim i as Integer +Dim sBookmarkName as String +Dim oDBBookmarks as Object +Dim bLinkExists as Boolean +Dim sBaseBookmarkName as String + sBookmarkName = GetFileNamewithoutExtension(FileNameoutofPath(sTargetPath)) + sBaseBookmarkName = sBookmarkName + oDBBookmarks = oDataSource.GetBookmarks() + i = 1 + Do + bLinkExists = oDBBookmarks.HasbyName(sBookmarkName) + If bLinkExists Then + i = i + 1 + sBookmarkName = sBaseBookmarkName & "_" & i + Else + oDBBookmarks.insertByName(sBookmarkName, sTargetPath) + End If + Loop Until Not bLinkExists + bDisposeDoc = False + GroupShapesTogether() + ToggleDesignMode(oDocument) + oDBForm.Reload() +End Sub + + +Sub StoreFormInDatabase() + Dim NoArgs() as new com.sun.star.beans.PropertyValue + FormName = "Form_" & sDBName & "_" & TableName & ".sxw" + sFormUrl = TempPath & "/" & FormName + oDocument.StoreAsUrl(sFormUrl, NoArgs()) + bdisposeDoc = true + DlgFormDB.Endexecute() +End Sub + + +Sub StoreForm() +Dim sTargetPath as String +Dim TypeNames(0,2) as String +Dim oMasterKey as Object +Dim oTypes() as Object + oMasterKey = GetRegistryKeyContent("org.openoffice.TypeDetection.Types/") + oTypes() = oMasterKey.Types + TypeNames(0,0) = GetFilterName("StarOffice XML (Writer)") + TypeNames(0,1) = "*.sxw" + TypeNames(0,2) = "" + StoreFormInDatabase() +' sTargetPath = StoreDocument(oDocument, TypeNames(), "Form_" & sDBName & "_" & TableName & ".sxw", WorkPath, 1) +End Sub + + +Sub EmptyFieldsListboxes() +Dim NullList() as String + ToggleListboxControls(DialogModel, False) + DialogModel.lstFields.StringItemList() = NullList() + DialogModel.lstSelFields.StringItemList() = NullList() + bEnableBinaryOptionGroup = False +End Sub + + +Sub DeleteFirstTableListBoxEntry() + DeleteFirstListBoxEntry("lstTables", sSelectDBTable) +End Sub + +Sub DeleteFirstListboxEntry(ListBoxName as String, DelEntryName as String) +Dim oListbox as Object +Dim sFirstItem as String +dim iSelPos as Integer + oListBox = DlgFormDB.getControl(ListBoxName) + sFirstItem = oListBox.getItem(0) + If sFirstItem = DelEntryName Then + iSelPos = oListBox.getSelectedItemPos() + oListBox.removeItems(0, 1) + If iSelPos > 0 Then + oListBox.selectItemPos(iSelPos-1, True) + End If + End If +End Sub + diff --git a/wizards/source/formwizard/Language.xba b/wizards/source/formwizard/Language.xba new file mode 100644 index 000000000..6346f8bae --- /dev/null +++ b/wizards/source/formwizard/Language.xba @@ -0,0 +1,297 @@ + + + +Option Explicit + + +Public Const SBCANCEL = 2 +Public Const SBREPEAT = 4 +Public LabelDiffHeight as Long +Public BasicLabelDiffHeight as Long + +Public WizardTitle(1 To 3) as String +Public DlgFormDB as Object +Public DialogModel as Object + +Dim sMsgWizardName as String +Dim sMsgErrMsg as String +Dim sMsgErrNoDatabase as String +Dim sMsgErrNoTableInDatabase as String +Dim sMsgErrTitleSuggestedExist as String +Dim sMsgErrTitleSyntaxError as String +Dim sMsgErrTitleAsTableExist as String +Dim sMsgProgressText as String +Dim sMsgCreatedForm as String +Dim sMsgErrCouldNotOpenObject as String +Dim sMsgErrNameToLong as String +Dim sTimeAppendix as String +Dim sDateAppendix as String +Public sGoOn as String +Public sReady as String +Public sMsgNoConnection as String +Public XPixelFactor as Long +Public YPixelFactor as Long +Public sSelectDatasource as String +Public sSelectDBTable as String + + + +Sub LoadLanguage () + sMsgWizardName = GetResText("RID_FORM_0") + sMsgErrMsg = GetResText("RID_DB_COMMON_6") + sMsgErrNoDatabase = GetResText("RID_DB_COMMON_8") + sMsgErrNoTableInDatabase = GetResText("RID_DB_COMMON_9") + sMsgErrTitleSuggestedExist = GetResText("RID_DB_COMMON_10") + sMsgErrTitleAsTableExist = GetResText("RID_DB_COMMON_10") + sMsgErrTitleSyntaxError = GetResText("RID_DB_COMMON_11") + sMsgNoConnection = GetResText("RID_DB_COMMON_14") + sMsgProgressText = GetResText("RID_FORM_2") + sMsgCreatedForm = GetResText("RID_FORM_26") + sMsgErrNameToLong = GetResText("RID_FORM_27") + sMsgErrCouldNotOpenObject = GetResText("RID_DB_COMMON_13") + + ' Internal Logic + sDateAppendix = GetResText("RID_FORM_4") + sTimeAppendix = GetResText("RID_FORM_5") + + sReady = GetResText("RID_DB_COMMON_0") +End Sub + + +Sub SetDialogLanguage () +Dim i as Integer +Dim ButtonHelpText as String +Dim CmdButton as Object +Dim IDArray as Variant +Dim FNameAddOn as String +Dim slblSelFields as String +Dim slblFields as String + + DlgFormDB = LoadDialog("FormWizard", "DlgFormDB") + DialogModel = DlgFormDB.Model + + With DialogModel + .cmdCancel.Label = GetResText("RID_DB_COMMON_1") + .cmdBack.Label = GetResText("RID_DB_COMMON_2") + .cmdHelp.Label = GetResText("RID_DB_COMMON_20") + sGoOn = GetResText("RID_DB_COMMON_3") + .cmdGoOn.Label = sGoOn + .lblTables.Label = GetResText("RID_FORM_6") + + slblFields = GetResText("RID_FORM_12") + slblSelFields = GetResText("RID_FORM_13") + .lblFields.Label = slblFields + .lblSelFields.Label = slblSelFields + + .lblStyles.Label = GetResText("RID_FORM_21") + .hlnBorderLayout.Label = GetResText("RID_FORM_28") + .hlnAlign.Label = GetResText("RID_FORM_32") + .hlnArrangements.Label = GetResText("RID_FORM_35") + + WizardTitle(1) = sMsgWizardName & " - " & GetResText("RID_FORM_45") + WizardTitle(2) = sMsgWizardName & " - " & GetResText("RID_FORM_46") + WizardTitle(3) = sMsgWizardName & " - " & GetResText("RID_FORM_47") + + .hlnBinaries.Label = GetResText("RID_FORM_50") + .optIgnoreBinaries.Label = GetResText("RID_FORM_51") + .optBinariesasGraphics.Label = GetResText("RID_FORM_52") + + .hlnBackground.Label = GetResText("RID_FORM_55") + .optTiled.Label = GetResText("RID_FORM_56") + .optArea.Label = GetResText("RID_FORM_57") + + .optBorder0.Label = GetResText("RID_FORM_29") + .optBorder1.Label = GetResText("RID_FORM_30") + .optBorder2.Label = GetResText("RID_FORM_31") + .optBorder1.State = 1 + + .optAlign0.Label = GetResText("RID_FORM_33") + .optAlign2.Label = GetResText("RID_FORM_34") + .optAlign0.State = 1 + + REM//FIXME: Remove this unused FNameAddOn through the file + FNameAddOn = "" + + IDArray = Array("RID_FORM_36", "RID_FORM_37", "RID_FORM_40", "RID_FORM_38", "RID_FORM_39") + For i = 1 To 5 + ButtonHelpText = GetResText(IDArray(i-1)) + cmdButton = DlgFormDB.getControl("cmdArrange" & i) + cmdButton.Model.ImageURL = FormPath & "Arrange_" & i & FNameAddOn & ".gif" + cmdButton.Model.HelpText = ButtonHelpText + cmdButton.getPeer().setProperty("AccessibleName", ButtonHelpText) + Next i +' .cmdArrange1.ImageURL = FormPath & "Arrange_1" & FNameAddOn & ".gif" +' .cmdArrange1.HelpText = GetResText("RID_FORM_36") +' +' .cmdArrange2.ImageURL = FormPath & "Arrange_2" & FNameAddOn & ".gif" +' .cmdArrange2.HelpText = GetResText("RID_FORM_37") +' +' .cmdArrange3.ImageURL = FormPath & "Arrange_3" & FNameAddOn & ".gif" +' .cmdArrange3.HelpText = GetResText("RID_FORM_40") +' +' .cmdArrange4.ImageURL = FormPath & "Arrange_4" & FNameAddOn & ".gif" +' .cmdArrange4.HelpText = GetResText("RID_FORM_38") +' +' .cmdArrange5.ImageURL = FormPath & "Arrange_5" & FNameAddOn & ".gif" +' .cmdArrange5.HelpText = GetResText("RID_FORM_39") + End With + DlgFormDB.GetControl("cmdMoveSelected").getPeer().setProperty("AccessibleName", GetResText("RID_DB_COMMON_39")) + DlgFormDB.GetControl("cmdRemoveSelected").getPeer().setProperty("AccessibleName", GetResText("RID_DB_COMMON_40")) + DlgFormDB.GetControl("cmdMoveAll").getPeer().setProperty("AccessibleName", GetResText("RID_DB_COMMON_41")) + DlgFormDB.GetControl("cmdRemoveAll").getPeer().setProperty("AccessibleName", GetResText("RID_DB_COMMON_42")) + DlgFormDB.getControl("lstFields").getPeer().setProperty("AccessibleName", DeleteStr(slblFields, "~")) + DlgFormDB.getControl("lstSelFields").getPeer().setProperty("AccessibleName", DeleteStr(slblSelFields, "~")) + + sSelectDatasource = GetResText("RID_DB_COMMON_37") + sSelectDBTable = GetResText("RID_DB_COMMON_38") +End Sub + + + +Sub InitializeWidthList() + + If Ubound(WidthList(),1) > 16 Then + ReDim WidthList(16,4) + End If + + WidthList(0,0) = com.sun.star.sdbc.DataType.BIT ' = -7; + WidthList(0,1) = cCheckbox + WidthList(0,2) = False + WidthList(0,3) = "CheckBox" + + WidthList(1,0) = com.sun.star.sdbc.DataType.TINYINT ' = -6; + WidthList(1,1) = cNumericBox + WidthList(1,2) = False + WidthList(1,3) = "FormattedField" + + WidthList(2,0) = com.sun.star.sdbc.DataType.SMALLINT ' = 5; + WidthList(2,1) = cNumericBox + WidthList(2,2) = False + WidthList(2,3) = "FormattedField" + + WidthList(3,0) = com.sun.star.sdbc.DataType.INTEGER ' = 4; + WidthList(3,1) = cNumericBox + WidthList(3,2) = False + WidthList(3,3) = "FormattedField" + + WidthList(4,0) = com.sun.star.sdbc.DataType.BIGINT ' = -5; + WidthList(4,1) = cNumericBox + WidthList(4,2) = False + WidthList(4,3) = "FormattedField" + + WidthList(5,0) = com.sun.star.sdbc.DataType.FLOAT ' = 6; + WidthList(5,1) = cNumericBox + WidthList(5,2) = False + WidthList(5,3) = "FormattedField" + + WidthList(6,0) = com.sun.star.sdbc.DataType.REAL ' = 7; + WidthList(6,1) = cNumericBox + WidthList(6,2) = False + WidthList(6,3) = "FormattedField" + + WidthList(7,0) = com.sun.star.sdbc.DataType.DOUBLE ' = 8; + WidthList(7,1) = cNumericBox + WidthList(7,2) = False + WidthList(7,3) = "FormattedField" + + WidthList(8,0) = com.sun.star.sdbc.DataType.NUMERIC ' = 2; + WidthList(8,1) = cNumericBox + WidthList(8,2) = False + WidthList(8,3) = "FormattedField" + + WidthList(9,0) = com.sun.star.sdbc.DataType.DECIMAL ' = 3; (including decimal places) + WidthList(9,1) = cNumericBox + WidthList(9,2) = False + WidthList(9,3) = "FormattedField" + + WidthList(10,0) = com.sun.star.sdbc.DataType.CHAR ' = 1; + WidthList(10,1) = cTextBox + WidthList(10,2) = False + WidthList(10,3) = "TextField" + + WidthList(11,0) = com.sun.star.sdbc.DataType.VARCHAR ' = 12; + WidthList(11,1) = cTextBox + WidthList(11,2) = True + WidthList(11,3) = "TextField" + + WidthList(12,0) = com.sun.star.sdbc.DataType.LONGVARCHAR ' = -1; + WidthList(12,1) = cTextBox + WidthList(12,2) = True + WidthList(12,3) = "TextField" + + WidthList(13,0) = com.sun.star.sdbc.DataType.DATE ' = 91; + WidthList(13,1) = cDateBox + WidthList(13,2) = False + WidthList(13,3) = "DateField" + + WidthList(14,0) = com.sun.star.sdbc.DataType.TIME ' = 92; + WidthList(14,1) = cTimeBox + WidthList(14,2) = False + WidthList(14,3) = "TimeField" + + WidthList(15,0) = com.sun.star.sdbc.DataType.TIMESTAMP ' = 93; + WidthList(15,1) = cDateBox + WidthList(15,2) = False + WidthList(15,3) = "DateField" + + WidthList(16,0) = com.sun.star.sdbc.DataType.BOOLEAN ' = 16; + WidthList(16,1) = cCheckbox + WidthList(16,2) = False + WidthList(16,3) = "CheckBox" + + ImgWidthList(0,0) = com.sun.star.sdbc.DataType.BINARY ' = -2; + ImgWidthList(0,1) = cImageControl + ImgWidthList(0,2) = False + ImgWidthList(0,3) = "ImageControl" + + ImgWidthList(1,0) = com.sun.star.sdbc.DataType.VARBINARY ' = -3; + ImgWidthList(1,1) = cImageControl + ImgWidthList(1,2) = False + ImgWidthList(1,3) = "ImageControl" + + ImgWidthList(2,0) = com.sun.star.sdbc.DataType.LONGVARBINARY ' = -4; + ImgWidthList(2,1) = cImageControl + ImgWidthList(2,2) = False + ImgWidthList(2,3) = "ImageControl" + + ImgWidthList(3,0) = com.sun.star.sdbc.DataType.BLOB ' = 2004; + ImgWidthList(3,1) = cImageControl + ImgWidthList(3,2) = False + ImgWidthList(3,3) = "ImageControl" + +' Note: the following Fieldtypes are ignored +'ExcludeList(0) = com.sun.star.sdbc.DataType.SQLNULL +'ExcludeList(1) = com.sun.star.sdbc.DataType.OTHER +'ExcludeList(2) = com.sun.star.sdbc.DataType.OBJECT +'ExcludeList(3) = com.sun.star.sdbc.DataType.DISTINCT +'ExcludeList(4) = com.sun.star.sdbc.DataType.STRUCT +'ExcludeList(5) = com.sun.star.sdbc.DataType.ARRAY +'ExcludeList(6) = com.sun.star.sdbc.DataType.CLOB +'ExcludeList(7) = com.sun.star.sdbc.DataType.REF + + oModelService(cLabel) = "com.sun.star.form.component.FixedText" + oModelService(cTextBox) = "com.sun.star.form.component.TextField" + oModelService(cCheckBox) = "com.sun.star.form.component.CheckBox" + oModelService(cDateBox) = "com.sun.star.form.component.DateField" + oModelService(cTimeBox) = "com.sun.star.form.component.TimeField" + oModelService(cNumericBox) = "com.sun.star.form.component.FormattedField" + oModelService(cGridControl) = "com.sun.star.form.component.GridControl" + oModelService(cImageControl) = "com.sun.star.form.component.DatabaseImageControl" +End Sub + diff --git a/wizards/source/formwizard/Layouter.xba b/wizards/source/formwizard/Layouter.xba new file mode 100644 index 000000000..24b209ad6 --- /dev/null +++ b/wizards/source/formwizard/Layouter.xba @@ -0,0 +1,397 @@ + + + +Option Explicit + +Public oProgressbar as Object +Public ProgressValue as Integer +Public oDocument as Object +Public oController as Object +Public oForm as Object +Public oDrawPage as Object +Public oPageStyle as Object + +Public nMaxColRightX as Long +Public nMaxTCWidth as Long +Public nMaxRowRightX as Long +Public nMaxRowY as Long +Public nSecMaxRowY as Long +Public MaxIndex as Integer +Public CurIndex as Integer + +Public Const cVertDistance = 200 +Public Const cHoriDistance = 300 + +Public nPageWidth as Long +Public nPageHeight as Long +Public nFormWidth as Long +Public nFormHeight as Long +Public nMaxHoriPos as Long +Public nMaxVertPos as Long + +Public CONST SBALIGNLEFT = 0 +Public CONST SBALIGNRIGHT = 2 + +Public Const SBNOBORDER = 0 +Public Const SB3DBORDER = 1 +Public Const SBSIMPLEBORDER = 2 + +Public CurArrangement as Integer +Public CurBorderType as Integer +Public CurAlignmode as Integer + +Public OldAlignMode as Integer +Public OldBorderType as Integer +Public OldArrangement as Integer + +Public Const cColumnarLeft = 1 +Public Const cColumnarTop = 2 +Public Const cTabled = 3 +Public Const cLeftJustified = 4 +Public Const cTopJustified = 5 + +Public Const cXOffset = 1000 +Public Const cYOffset = 700 +' This is the viewed space that we lose because of the symbol bars +Public Const cSymbolMargin = 2000 +Public Const MaxFieldIndex = 200 + +Public Const cControlCollectionCount = 9 +Public Const cLabel = 1 +Public Const cTextBox = 2 +Public Const cCheckBox = 3 +Public Const cDateBox = 4 +Public Const cTimeBox = 5 +Public Const cNumericBox = 6 +Public Const cCurrencyBox = 7 +Public Const cGridControl = 8 +Public Const cImageControl = 9 + +Public Styles(100, 8) as String + +Public CurControlType as Integer +Public CurFieldlength as Double +Public CurFieldType as Integer +Public CurFieldName as String +Public CurControlName as String +Public CurFormatKey as Long +Public CurDefaultValue +Public CurIsCurrency as Boolean +Public CurScale as Integer +Public CurHelpText as String + +Public FieldMetaValues(MaxFieldIndex, 8) +' Description of this List: +' CurFieldType = FieldMetaValues(Index,0) +' CurFieldLength = FieldMetaValues(Index,1) +' CurControlType = FieldMetaValues(Index,2) (ControlType, e.g., cLabel, cTextbox, etc.) +' CurControlName = FieldMetaValues(Index,3) +' CurFormatKey = FieldMetaValues(Index,4) +' CurDefaultValue = FieldMetaValues(Index,5) +' CurIsCurrency = FieldMetaValues(Index,6) +' CurScale = FieldMetaValues(Index,7) +' CurHelpText = FieldMetaValues(Index,8) + +Public FieldNames(MaxFieldIndex) as string +Public oModelService(cControlCollectionCount) as String +Public oGridModel as Object + + +Function InsertControl(oContainer as Object, oControlObject as object, aPoint as Object, aSize as Object) +Dim oShape as object + oShape = oDocument.CreateInstance ("com.sun.star.drawing.ControlShape") + oShape.Size = aSize + oShape.Position = aPoint + oShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH + oShape.control = oControlObject + oContainer.Add(oShape) + InsertControl() = oShape +End Function + + +Function ArrangeControls() +Dim oShape as Object +Dim i as Integer + oProgressbar = oDocument.GetCurrentController.GetFrame.CreateStatusIndicator + oProgressbar.Start("", MaxIndex) + If oDBForm.HasbyName("Grid1") Then + RemoveShapes() + End If + ToggleLayoutPage(False) + Select Case CurArrangement + Case cTabled + PositionGridControl(MaxIndex) + Case Else + PositionControls(MaxIndex) + End Select + ToggleLayoutPage(True) + oProgressbar.End +End Function + + +Sub OpenFormDocument() +Dim NoArgs() as new com.sun.star.beans.PropertyValue +Dim oViewSettings as Object + oDocument = CreateNewDocument("swriter") + oProgressbar = oDocument.GetCurrentController.GetFrame.CreateStatusIndicator() + oProgressbar.Start("", 100) + oDocument.ApplyFormDesignMode = False + oController = oDocument.GetCurrentController + oViewSettings = oDocument.CurrentController.ViewSettings + oViewSettings.ShowTableBoundaries = False + oViewSettings.ShowOnlineLayout = True + oDrawPage = oDocument.DrawPage + oPageStyle = oDocument.StyleFamilies.GetByName("PageStyles").GetByName("Standard") +End Sub + + +Sub InitializeLabelValues() +Dim oLabelModel as Object +Dim oTBModel as Object +Dim oLabelShape as Object +Dim oTBShape as Object +Dim aTBSize As New com.sun.star.awt.Size +Dim aLabelSize As New com.sun.star.awt.Size +Dim aPoint As New com.sun.star.awt.Point +Dim aSize As New com.sun.star.awt.Size +Dim oLocControl as Object +Dim oLocPeer as Object + oLabelModel = CreateUnoService("com.sun.star.form.component.FixedText") + oTBModel = CreateUnoService("com.sun.star.form.component.TextField") + + Set oLabelShape = InsertControl(oDrawPage, oLabelModel, aPoint, aLabelSize) + Set oTBShape = InsertControl(oDrawPage, oTBModel, aPoint, aSize) + + oLocPeer = oController.GetControl(oLabelModel).Peer + XPixelFactor = 100000/oLocPeer.GetInfo.PixelPerMeterX + YPixelFactor = 100000/oLocPeer.GetInfo.PixelPerMeterY + aLabelSize = GetPeerSize(oLabelModel, oLocControl, "The quick brown fox...") + nTCHeight = (aLabelSize.Height+1) * YPixelFactor + aTBSize = GetPeerSize(oTBModel, oLocControl, "The quick brown fox...") + nDBRefHeight = (aTBSize.Height+1) * YPixelFactor + BasicLabelDiffHeight = Clng((nDBRefHeight - nTCHeight)/2) + oDrawPage.Remove(oLabelShape) + oDrawPage.Remove(oTBShape) +End Sub + + +Sub ConfigurePageStyle() +Dim aPageSize As New com.sun.star.awt.Size +Dim aSize As New com.sun.star.awt.Size + oPageStyle.IsLandscape = True + aPageSize = oPageStyle.Size + nPageWidth = aPageSize.Width + nPageHeight = aPageSize.Height + aSize.Width = nPageHeight + aSize.Height = nPageWidth + oPageStyle.Size = aSize + nPageWidth = nPageHeight + nPageHeight = oPageStyle.Size.Height + nFormWidth = nPageWidth - oPageStyle.RightMargin - oPageStyle.LeftMargin - 2 * cXOffset + nFormHeight = nPageHeight - oPageStyle.TopMargin - oPageStyle.BottomMargin - 2 * cYOffset - cSymbolMargin +End Sub + + +' Modify the Borders of the Controls +Sub ChangeBorderLayouts(oEvent as Object) +Dim oModel as Object +Dim i as Integer +Dim oCurModel as Object +Dim sLocText as String +Dim oGroupShape as Object +Dim s as Integer + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + oModel = oEvent.Source.Model + SwitchBorderMode(Val(Right(oModel.Name,1))) + ToggleLayoutPage(False) + If CurArrangement = cTabled Then + oGridModel.Border = CurBorderType + Else + If OldBorderType <> CurBorderType Then + For i = 0 To MaxIndex + If oDBShapeList(i).SupportsService("com.sun.star.drawing.GroupShape") Then + oGroupShape = oDBShapeList(i) + For s = 0 To oGroupShape.Count-1 + oGroupShape(s).Control.Border = CurBorderType + Next s + Else + If oDBModelList(i).PropertySetInfo.HasPropertyByName("Border") Then + oDBModelList(i).Border = CurBorderType + End If + End If + Next i + End If + End If + ToggleLayoutPage(True) +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + DlgFormDB.Dispose() + End If +End Sub + + +Sub ChangeLabelAlignments(oEvent as Object) +Dim i as Integer +Dim oSize as New com.sun.star.awt.Size +Dim oModel as Object + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + oModel = oEvent.Source.Model + SwitchAlignMode(Val(Right(oModel.Name,1))) + ToggleLayoutPage(False) + If OldAlignMode <> CurAlignMode Then + For i = 0 To MaxIndex + oTCShapeList(i).GetControl.Align = CurAlignmode + Next i + End If + If CurAlignmode = com.sun.star.awt.TextAlign.RIGHT Then + For i = 0 To Ubound(oTCShapeList()) + oSize = oTCShapeList(i).Size + oSize.Width = oDBShapeList(i).Position.X - oTCShapeList(i).Position.X - cHoriDistance + oTCShapeList(i).Size = oSize + Next i + End If + +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If + ToggleLayoutPage(True) +End Sub + + +Sub ChangeArrangemode(oEvent as Object) +Dim oModel as Object + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + oModel = oEvent.Source.Model + SwitchArrangementButtons(Val(Right(oModel.Name,1))) + oModel.State = 1 + DlgFormDB.GetControl("cmdArrange" & OldArrangement).Model.State = 0 + If CurArrangement <> OldArrangement Then + ArrangeControls() + Select Case CurArrangement + Case cTabled + ToggleBorderGroup(False) + ToggleAlignGroup(False) + Case Else ' cColumnarTop,cLeftJustified, cTopJustified + ToggleAlignGroup(CurArrangement = cColumnarLeft) + If CurArrangement = cColumnarTop Then + If CurAlignMode = com.sun.star.awt.TextAlign.RIGHT Then + DialogModel.optAlign0.State = 1 + CurAlignMode = com.sun.star.awt.TextAlign.LEFT + OldAlignMode = com.sun.star.awt.TextAlign.RIGHT + End If + End If + ControlCaptionstoStandardLayout() + oDBForm.Load + End Select + End If +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If +End Sub + + +Sub ToggleBorderGroup(bDoEnable as Boolean) + With DialogModel + .hlnBorderLayout.Enabled = bDoEnable + .optBorder0.Enabled = bDoEnable ' 0: No border + .optBorder1.Enabled = bDoEnable ' 1: 3D border + .optBorder2.Enabled = bDoEnable ' 2: simple border + End With +End Sub + + +Sub ToggleAlignGroup(ByVal bDoEnable as Boolean) + With DialogModel + If bDoEnable Then + bDoEnable = CurArrangement = cColumnarLeft + End If + .hlnAlign.Enabled = bDoEnable + .optAlign0.Enabled = bDoEnable + .optAlign2.Enabled = bDoEnable + End With +End Sub + + +Sub ToggleLayoutPage(bDoEnable as Boolean, Optional FocusControlName as String) + DialogModel.Enabled = bDoEnable + If bDoEnable Then + If Not bDebug Then + oDocument.UnlockControllers() + End If + ToggleOptionButtons(DialogModel,(bWithBackGraphic = True)) + ToggleAlignGroup(bDoEnable) + ToggleBorderGroup(bDoEnable) + Else + If Not bDebug Then + oDocument.LockControllers() + End If + End If + If Not IsMissing(FocusControlName) Then + DlgFormDB.GetControl(FocusControlName).SetFocus() + End If +End Sub + + +Sub DestroyControlShapes(oDrawPage as Object) +Dim i as Integer +Dim oShape as Object + For i = oDrawPage.Count-1 To 0 Step -1 + oShape = oDrawPage.GetByIndex(i) + If oShape.ShapeType = "com.sun.star.drawing.ControlShape" Then + oShape.Dispose() + End If + Next i +End Sub + + +Sub SwitchArrangementButtons(ByVal LocArrangement as Integer) + OldArrangement = CurArrangement + CurArrangement = LocArrangement + If OldArrangement <> 0 Then + DlgFormDB.GetControl("cmdArrange" & OldArrangement).Model.State = 0 + End If + DlgFormDB.GetControl("cmdArrange" & CurArrangement).Model.State = 1 +End Sub + + +Sub SwitchBorderMode(ByVal LocBorderType as Integer) + OldBorderType = CurBorderType + CurBorderType = LocBorderType +End Sub + + +Sub SwitchAlignMode(ByVal LocAlignMode as Integer) + OldAlignMode = CurAlignMode + CurAlignMode = LocAlignMode +End Sub \ No newline at end of file diff --git a/wizards/source/formwizard/develop.xba b/wizards/source/formwizard/develop.xba new file mode 100644 index 000000000..ce5730f58 --- /dev/null +++ b/wizards/source/formwizard/develop.xba @@ -0,0 +1,550 @@ + + + +REM ***** BASIC ***** +Option Explicit + +Public oDBShapeList() as Object +Public oTCShapeList() as Object +Public oDBModelList() as Object +Public oGroupShapeList() as Object + +Public oGridShape as Object +Public a as Integer +Public StartA as Integer +Public bIsFirstRun as Boolean +Public bIsVeryFirstRun as Boolean +Public bControlsareCreated as Boolean +Public nDBRefHeight as Long +Public nXTCPos&, nYTCPos&, nXDBPos&, nYDBPos&, nTCHeight&, nTCWidth&, nDBHeight&, nDBWidth& + +Dim iReduceWidth as Integer + +Function PositionControls(Maxindex as Integer) +Dim oTCModel as Object +Dim oDBModel as Object +Dim i as Integer + InitializePosSizes() + bIsFirstRun = True + bIsVeryFirstRun = True + a = 0 + StartA = 0 + nMaxRowY = 0 + nSecMaxRowY = 0 + If CurArrangement = cLeftJustified Or cTopJustified Then + DialogModel.optAlign0.State = 1 + End If + For i = 0 To MaxIndex + GetCurrentMetaValues(i) + oTCModel = InsertTextControl(i) + If CurFieldType = com.sun.star.sdbc.DataType.TIMESTAMP Then + InsertTimeStampShape(i) + Else + InsertDBControl(i) + bIsVeryFirstRun = False + oDBModelList(i).LabelControl = oTCModel + End If + GetLabelDiffHeight(i+1) + ResetPosSizes(i) + oProgressbar.Value = i + Next i + ControlCaptionstoStandardLayout() + bControlsareCreated = True +End Function + + +Sub ResetPosSizes(LastIndex as Integer) + Select Case CurArrangement + Case cColumnarLeft + nYDBPos = nYDBPos + nDBHeight + cVertDistance + If (nYDBPos > cYOffset + nFormHeight) Or (LastIndex = MaxIndex) Then + RepositionColumnarLeftControls(LastIndex) + nXTCPos = nMaxColRightX + 2 * cHoriDistance + nXDBPos = nXTCPos + cHoriDistance + nMaxTCWidth + nYDBPos = cYOffset + bIsFirstRun = True + StartA = LastIndex + 1 + a = 0 + Else + a = a + 1 + End If + nYTCPos = nYDBPos + LABELDIFFHEIGHT + Case cColumnarTop + nYTCPos = nYDBPos + nDBHeight + cVertDistance + If nYTCPos > cYOffset + nFormHeight Then + nXDBPos = nMaxColRightX + cHoriDistance + nXTCPos = nXDBPos + nYDBPos = cYOffset + nTCHeight + cVertDistance + nYTCPos = cYOffset + bIsFirstRun = True + StartA = LastIndex + 1 + a = 0 + Else + a = a + 1 + End If + Case cLeftJustified,cTopJustified + If nMaxColRightX > cXOffset + nFormWidth Then + Dim nOldYTCPos as Long + nOldYTCPos = nYTCPos + CheckJustifiedPosition() + Else + nXTCPos = nMaxColRightX + CHoriDistance + If CurArrangement = cLeftJustified Then + nYTCPos = nYDBPos + LabelDiffHeight + End If + End If + a = a + 1 + End Select +End Sub + + +Sub RepositionColumnarLeftControls(LastIndex as Integer) +Dim aSize As New com.sun.star.awt.Size +Dim aPoint As New com.sun.star.awt.Point +Dim i as Integer + aSize = GetSize(nMaxTCWidth, nTCHeight) + bIsFirstRun = True + For i = StartA To LastIndex + If i = StartA Then + nXTCPos = oTCShapeList(i).Position.X + nXDBPos = nXTCPos + nMaxTCWidth + cHoriDistance + End If + ResetDBShape(oDBShapeList(i), nXDBPos) + CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True) + Next i +End Sub + + +Sub ResetDBShape(oLocDBShape as Object, iXPos as Long) +Dim aSize As New com.sun.star.awt.Size +Dim aPoint As New com.sun.star.awt.Point + nYDBPos = oLocDBShape.Position.Y + nDBWidth = oLocDBShape.Size.Width + nDBHeight = oLocDBShape.Size.Height + aPoint = GetPoint(iXPos,nYDBPos) + oLocDBShape.SetPosition(aPoint) +End Sub + + +Sub InitializePosSizes() + nXTCPos = cXOffset + nTCWidth = 2000 + nDBWidth = 2000 + nDBHeight = nDBRefHeight + iReduceWidth = 0 + Select Case CurArrangement + Case cColumnarLeft, cLeftJustified + GetLabelDiffHeight(0) + nYTCPos = cYOffset + LABELDIFFHEIGHT + nXDBPos = cXOffset + 3050 + nYDBPos = cYOffset + Case cColumnarTop, cTopJustified + nXDBPos = cXOffset + nYTCPos = cYOffset + End Select +End Sub + + +Function InsertTextControl(i as Integer) as Object +Dim oShape as Object +Dim oModel as Object +Dim aPoint as New com.sun.star.awt.Point +Dim aSize As New com.sun.star.awt.Size + If bControlsareCreated Then + Set oShape = oTCShapeList(i) + Set oModel = oShape.GetControl + If CurArrangement = cLeftJustified Then + nTCWidth = GetPreferredWidth(oModel, True, CurFieldname) + Else + nTCWidth = oShape.Size.Width + End If + oShape.Position = GetPoint(nXTCPos, nYTCPos) + If CurArrangement = cColumnarTop Then + oModel.Align = com.sun.star.awt.TextAlign.LEFT + End If + Else + oModel = CreateUnoService(oModelService(cLabel)) + aPoint = GetPoint(nXTCPos, nYTCPos) + aSize = GetSize(nTCWidth,nTCHeight) + Set oShape = InsertControl(oDrawPage, oModel, aPoint, aSize) + Set oTCShapeList(i)= oShape + If bIsVeryFirstRun Then + If CurArrangement = cColumnarTop Then + nYDBPos = nYTCPos + nTCHeight + End If + End If + nTCWidth = GetPreferredWidth(oModel, True, CurFieldName) + End If + If CurArrangement = cColumnarLeft Then + ' Note This If Sequence must be called before retrieving the outer Points + If bIsFirstRun Then + nMaxTCWidth = nTCWidth + bIsFirstRun = False + ElseIf nTCWidth > nMaxTCWidth Then + nMaxTCWidth = nTCWidth + End If + End If + CheckOuterPoints(oShape.Position.X, nTCWidth, nYTCPos, nTCHeight, False) + Select Case CurArrangement + Case cLeftJustified + nXDBPos = nMaxColRightX + Case cColumnarTop,cTopJustified + oModel.Align = com.sun.star.awt.TextAlign.LEFT + nXDBPos = nXTCPos + nYDBPos = nYTCPos + nTCHeight + If CurFieldLength = 20 And nDBWidth > 2 * nTCWidth Then + iReduceWidth = iReduceWidth + 1 + End If + End Select + oShape.SetSize(GetSize(nTCWidth,nTCHeight)) + If CurHelpText <> "" Then + oModel.HelpText = CurHelptext + End If + InsertTextControl = oModel +End Function + + +Sub InsertDBControl(i as Integer) +Dim aPoint as New com.sun.star.awt.Point +Dim aSize As New com.sun.star.awt.Size +Dim oControl as Object +Dim iColRightX as Long + + aPoint = GetPoint(nXDBPos, nYDBPos) + If bControlsAreCreated Then + oDBShapeList(i).Position = aPoint + Else + oDBModelList(i) = CreateUnoService(oModelService(CurControlType)) + oDBShapeList(i) = InsertControl(oDrawPage, oDBModelList(i), aPoint, aSize) + SetNumerics(oDBModelList(i), CurFieldType) + If CurControlType = cCheckBox Then + oDBModelList(i).Label = "" + End If + oDBModelList(i).DataField = CurFieldName + End If + nDBHeight = GetDBHeight(oDBModelList(i)) + nDBWidth = GetPreferredWidth(oDBModelList(i),True) + aSize = GetSize(nDBWidth,nDBHeight) + oDBShapeList(i).SetSize(aSize) + CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True) +End Sub + + +Function InsertTimeStampShape(i as Integer) as Object +Dim oDateModel as Object +Dim oTimeModel as Object +Dim oDateShape as Object +Dim oTimeShape as Object +Dim oDateTimeShape as Object +Dim aPoint as New com.sun.star.awt.Point +Dim aSize as New com.sun.star.awt.Size +Dim nDateWidth as Long +Dim nTimeWidth as Long +Dim oGroupShape as Object + aPoint = GetPoint(nXDBPos, nYDBPos) + If bControlsAreCreated Then + oDBShapeList(i).Position = aPoint + nDBWidth = oDBShapeList(i).Size.Width + nDBHeight = oDBShapeList(i).Size.Height + Else + oGroupShape = oDocument.CreateInstance("com.sun.star.drawing.GroupShape") + oGroupShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH + oDrawPage.Add(oGroupShape) + CurFieldType = com.sun.star.sdbc.DataType.DATE + oDateModel = CreateUnoService("com.sun.star.form.component.DateField") + oDateModel.DataField = CurFieldName + oDateShape = InsertControl(oGroupShape, oDateModel, aPoint, aSize) + SetNumerics(oDateModel, CurFieldType) + nDBHeight = GetDBHeight(oDateModel) + nDateWidth = GetPreferredWidth(oDateModel,True) + aSize = GetSize(nDateWidth,nDBHeight) + oDateShape.SetSize(aSize) + + CurFieldType = com.sun.star.sdbc.DataType.TIME + oTimeModel = CreateUnoService("com.sun.star.form.component.TimeField") + oTimeModel.DataField = CurFieldName + oTimeShape = InsertControl(oGroupShape, oTimeModel, aPoint, aSize) + oTimeShape.Position = GetPoint(nXDBPos + 10 + nDateWidth,nYDBPos) + nTimeWidth = GetPreferredWidth(oTimeModel) + aSize = GetSize(nTimeWidth,nDBHeight) + oTimeShape.SetSize(aSize) + nDBWidth = nDateWidth + nTimeWidth + 10 + oGroupShape.Position = aPoint + oGroupShape.Size = GetSize(nDBWidth, nDBHeight) + Set oDBShapeList(i)= oGroupShape + End If + CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True) + InsertTimeStampShape() = oDBShapeList(i) +End Function + + +' Note: on all Controls except for the checkbox the Label has to be set +' a bit under the DBControl because its Height is also smaller +Sub GetLabelDiffHeight(Index as Integer) + If (CurArrangement = cLeftJustified) Or (CurArrangement = cColumnarLeft) Then + If Index <= Ubound(FieldMetaValues()) Then + If FieldMetaValues(Index,2) = cCheckBox Then + LabelDiffHeight = 0 + Else + LabelDiffHeight = BasicLabelDiffHeight + End If + End If + End If +End Sub + + +Sub CheckJustifiedPosition() +Dim nLeftDist as Long +Dim nRightDist as Long +Dim oLocDBShape as Object +Dim oLocTextShape as Object +Dim nBaseWidth as Long + nBaseWidth = nFormWidth + cXOffset + nLeftDist = nMaxColRightX - nBaseWidth + nRightDist = nBaseWidth - nXTCPos + cHoriDistance + If nLeftDist < 0.5 * nRightDist and iReduceWidth > 2 Then + ' Fieldwidths in the line can be made smaller + AdjustLineWidth(StartA, a, nLeftDist, - 1) + If CurArrangement = cLeftjustified Then + nYDBPos = nMaxRowY + cVertDistance + nYTCPos = nYDBPos + LABELDIFFHEIGHT + nXTCPos = cXOffset + Else + nYTCPos = nMaxRowY + cVertDistance + nYDBPos = nYTCPos + nTCHeight + nXTCPos = cXOffset + nXDBPos = cXOffset + End If + bIsFirstRun = True + StartA = a + 1 + Else + Set oLocDBShape = oDBShapeList(a) + Set oLocTextShape = oTCShapeList(a) + If CurArrangement = cLeftJustified Then + If nYDBPos + nDBHeight = nMaxRowY Then + ' The last Control was the highest in the row + nYDBPos = nSecMaxRowY + cVertDistance + Else + nYDBPos = nMaxRowY + cVertDistance + End If + nYTCPos = nYDBPos + LABELDIFFHEIGHT + nXDBPos = cXOffset + nTCWidth + oLocTextShape.Position = GetPoint(cXOffset, nYTCPos) + oLocDBShape.Position = GetPoint(nXDBPos, nYDBPos) + ' PosSizes for the next two Controls + nXTCPos = oLocDBShape.Position.X + oLocDBShape.Size.Width + cHoriDistance + bIsFirstRun = True + CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True) + nXDBPos = nMaxColRightX + cHoriDistance + Else ' cTopJustified + If nYDBPos + nDBHeight = nMaxRowY Then + ' The last Control was the highest in the row + nYTCPos = nSecMaxRowY + cVertDistance + Else + nYTCPos = nMaxRowY + cVertDistance + End If + nYDBPos = nYTCPOS + nTCHeight + nXDBPos = cXOffset + nXTCPos = cXOffset + oLocTextShape.Position = GetPoint(cXOffset, nYTCPos) + oLocDBShape.Position = GetPoint(cXOffset, nYDBPos) + bIsFirstRun = True + If nDBWidth > nTCWidth Then + CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True) + Else + CheckOuterPoints(nXDBPos, nTCWidth, nYDBPos, nDBHeight, True) + End If + nXTCPos = nMaxColRightX + cHoriDistance + nXDBPos = nXTCPos + End If + AdjustLineWidth(StartA, a-1, nRightDist, 1) + StartA = a + End If + iReduceWidth = 0 +End Sub + + + +Function GetCorrWidth(StartIndex as Integer, EndIndex as Integer, nDist as Long, Widthfactor as Integer) as Integer +Dim ShapeCount as Integer + If WidthFactor > 0 Then + ShapeCount = EndIndex-StartIndex + 1 + Else + ShapeCount = iReduceWidth + End If + GetCorrWidth() = (nDist)/ShapeCount +End Function + + +Sub AdjustLineWidth(StartIndex as Integer, EndIndex as Integer, nDist as Long, Widthfactor as Integer) +Dim i as Integer +Dim oLocDBShape as Object +Dim oLocTCShape as Object +Dim CorrWidth as Integer +Dim bAdjustPos as Boolean +Dim iLocTCPosX as Long +Dim iLocDBPosX as Long + CorrWidth = GetCorrWidth(StartIndex, EndIndex, nDist, Widthfactor) + bAdjustPos = False + iLocTCPosX = cXOffset + For i = StartIndex To EndIndex + Set oLocDBShape = oDBShapeList(i) + Set oLocTCShape = oTCShapeList(i) + If bAdjustPos Then + oLocTCShape.Position = GetPoint(iLocTCPosX, oLocTCShape.Position.Y) + If CurArrangement = cLeftJustified Then + iLocDBPosX = oLocTCShape.Position.X + oLocTCShape.Size.Width + oLocDBShape.Position = GetPoint(iLocDBPosX, oLocDBShape.Position.Y) + Else + oLocDBShape.Position = GetPoint(iLocTCPosX, oLocTCShape.Position.Y + nTCHeight) + End If + Else + bAdjustPos = True + End If + If CDbl(FieldMetaValues(i,1)) > 20 or WidthFactor > 0 Then + If (CurArrangement = cTopJustified) And (oLocTCShape.Size.Width > oLocDBShape.Size.Width) Then + oLocDBShape.Size = GetSize(oLocTCShape.Size.Width + WidthFactor * CorrWidth, oLocDBShape.Size.Height) + Else + oLocDBShape.Size = GetSize(oLocDBShape.Size.Width + WidthFactor * CorrWidth, oLocDBShape.Size.Height) + End If + End If + iLocTCPosX = oLocDBShape.Position.X + oLocDBShape.Size.Width + cHoriDistance + If CurArrangement = cTopJustified Then + If oLocTCShape.Size.Width > oLocDBShape.Size.Width Then + iLocTCPosX = oLocDBShape.Position.X + oLocTCShape.Size.Width + cHoriDistance + End If + End If + Next i +End Sub + + +Sub CheckOuterPoints(nXPos, nWidth, nYPos, nHeight, bIsDBField as Boolean) +Dim nColRightX as Long +Dim nRowY as Long +Dim nOldMaxRowY as Long + If CurArrangement = cLeftJustified Or CurArrangement = cTopJustified Then + If bIsDBField Then + ' Only at DBControls you can measure the Value of nMaxRowY + If bIsFirstRun Then + nMaxRowY = nYPos + nHeight + nSecMaxRowY = nMaxRowY + Else + nRowY = nYPos + nHeight + If nRowY >= nMaxRowY Then + nOldMaxRowY = nMaxRowY + nSecMaxRowY = nOldMaxRowY + nMaxRowY = nRowY + End If + End If + End If + End If + ' Find the outer right point + If bIsFirstRun Then + nMaxColRightX = nXPos + nWidth + bIsFirstRun = False + Else + nColRightX = nXPos + nWidth + If nColRightX > nMaxColRightX Then + nMaxColRightX = nColRightX + End If + End If +End Sub + + +Function PositionGridControl(MaxIndex as Integer) +Dim oControl as Object +Dim n as Integer +Dim oColumn as Object +Dim aPoint as New com.sun.star.awt.Point +Dim aSize as New com.sun.star.awt.Size + If bControlsareCreated Then + ShapesToNirwana() + End If + oGridModel = CreateUnoService(oModelService(cGridControl)) + oGridModel.Name = "Grid1" + aPoint = GetPoint(cXOffset, cYOffset) + aSize = GetSize(nFormWidth, nFormHeight) + oDBForm.InsertByName (oGridModel.Name, oGridModel) + oGridShape = InsertControl(oDrawPage, oGridModel, aPoint, aSize) + For n = 0 to MaxIndex + GetCurrentMetaValues(n) + If CurFieldType = com.sun.star.sdbc.DataType.TIMESTAMP Then + oColumn = SetupGridColumn(oGridModel,"DateField", False, com.sun.star.sdbc.DataType.DATE, CurFieldName & " " & sDateAppendix) + oColumn = SetupGridColumn(oGridModel,"TimeField", False, com.sun.star.sdbc.DataType.TIME, CurFieldName & " " & sTimeAppendix) + Else + If CurControlType = cImageControl Then + oColumn = SetupGridColumn(oGridModel,"TextField", True, CurFieldType, CurFieldName) + Else + oColumn = SetupGridColumn(oGridModel, CurControlName, False, CurFieldType, CurFieldName) + End If + End If + oProgressbar.Value = n + next n +End Function + + +Function SetupGridColumn(oGridModel as Object, ControlName as String, bHidden as Boolean, iLocFieldType as Integer, ColName as String) as Object +Dim oColumn as Object + CurControlName = ControlName + oColumn = oGridModel.CreateColumn(CurControlName) + oColumn.Name = CalcUniqueContentName(oGridModel, CurControlName) + oColumn.Hidden = bHidden + SetNumerics(oColumn, iLocFieldType) + oColumn.DataField = CurFieldName + oColumn.Label = ColName + oColumn.Width = 0 ' Width of column is adjusted to Columname + oGridModel.insertByName(oColumn.Name, oColumn) +End Function + + +Sub ControlCaptionstoStandardLayout() +Dim i as Integer +Dim iBorderType as Integer +Dim oCurModel as Object +Dim oStyle as Object +Dim iStandardColor as Long + If CurArrangement <> cTabled Then + oStyle = oDocument.StyleFamilies.GetByName("ParagraphStyles").GetByName("Standard") + iStandardColor = oStyle.CharColor + For i = 0 To MaxIndex + oCurModel = oTCShapeList(i).GetControl + If i = 0 Then + If oCurModel.TextColor = iStandardColor Then + Exit Sub + End If + End If + oCurModel.TextColor = iStandardColor + Next i + End If +End Sub + + +Sub GroupShapesTogether() +Dim i as Integer + If CurArrangement <> cTabled Then + For i = 0 To MaxIndex + oGroupShapeList(i) = CreateUnoService("com.sun.star.drawing.ShapeCollection") + oGroupShapeList(i).Add(oTCShapeList(i)) + oGroupShapeList(i).Add(oDBShapeList(i)) + oDrawPage.Group(oGroupShapeList(i)) + Next i + Else + RemoveNirwanaShapes() + End If +End Sub diff --git a/wizards/source/formwizard/dialog.xlb b/wizards/source/formwizard/dialog.xlb new file mode 100644 index 000000000..d680f2929 --- /dev/null +++ b/wizards/source/formwizard/dialog.xlb @@ -0,0 +1,5 @@ + + + + + diff --git a/wizards/source/formwizard/script.xlb b/wizards/source/formwizard/script.xlb new file mode 100644 index 000000000..0b79b7f07 --- /dev/null +++ b/wizards/source/formwizard/script.xlb @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/wizards/source/formwizard/tools.xba b/wizards/source/formwizard/tools.xba new file mode 100644 index 000000000..881552717 --- /dev/null +++ b/wizards/source/formwizard/tools.xba @@ -0,0 +1,363 @@ + + + +REM ***** BASIC ***** +Option Explicit +Public Const SBMAXTEXTSIZE = 50 + + +Function SetProgressValue(iValue as Integer) + If iValue = 0 Then + oProgressbar.End + End If + ProgressValue = iValue + oProgressbar.Value = iValue +End Function + + +Function GetPreferredWidth(oModel as Object, bGetMaxWidth as Boolean, Optional LocText) +Dim aPeerSize as new com.sun.star.awt.Size +Dim nWidth as Integer +Dim oControl as Object + If Not IsMissing(LocText) Then + ' Label + aPeerSize = GetPeerSize(oModel, oControl, LocText) + ElseIf CurControlType = cImageControl Then + GetPreferredWidth() = 2000 + Exit Function + Else + aPeerSize = GetPeerSize(oModel, oControl) + End If + nWidth = aPeerSize.Width + ' We increase the preferred Width a bit so that the control does not become too small + ' when we change the border from "3D" to "Flat" + GetPreferredWidth = (nWidth + 10) * XPixelFactor ' PixelTo100thmm(nWidth) +End Function + + +Function GetPreferredHeight(oModel as Object, Optional LocText) +Dim aPeerSize as new com.sun.star.awt.Size +Dim nHeight as Integer +Dim oControl as Object + If Not IsMissing(LocText) Then + ' Label + aPeerSize = GetPeerSize(oModel, oControl, LocText) + ElseIf CurControlType = cImageControl Then + GetPreferredHeight() = 2000 + Exit Function + Else + aPeerSize = GetPeerSize(oModel, oControl) + End If + nHeight = aPeerSize.Height + ' We increase the preferred Height a bit so that the control does not become too small + ' when we change the border from "3D" to "Flat" + GetPreferredHeight = (nHeight+1) * YPixelFactor ' PixelTo100thmm(nHeight) +End Function + + +Function GetPeerSize(oModel as Object, oControl as Object, Optional LocText) +Dim oPeer as Object +Dim aPeerSize as new com.sun.star.awt.Size +Dim NullValue + oControl = oController.GetControl(oModel) + oPeer = oControl.GetPeer() + If oControl.Model.PropertySetInfo.HasPropertybyName("EffectiveMax") Then + If oControl.Model.EffectiveMax = 0 Then + ' This is relevant for decimal fields + oControl.Model.EffectiveValue = 999.9999 + Else + oControl.Model.EffectiveValue = oControl.Model.EffectiveMax + End If + GetPeerSize() = oPeer.PreferredSize() + oControl.Model.EffectiveValue = NullValue + ElseIf Not IsMissing(LocText) Then + oControl.Text = LocText + GetPeerSize() = oPeer.PreferredSize() + ElseIf CurFieldType = com.sun.star.sdbc.DataType.BIT Then + GetPeerSize() = oPeer.PreferredSize() + ElseIf CurFieldType = com.sun.star.sdbc.DataType.BOOLEAN Then + GetPeerSize() = oPeer.PreferredSize() + ElseIf CurFieldType = com.sun.star.sdbc.DataType.DATE Then + oControl.Model.Date = Date + GetPeerSize() = oPeer.PreferredSize() + oControl.Model.Date = NullValue + ElseIf CurFieldType = com.sun.star.sdbc.DataType.TIME Then + oControl.Time = Time + GetPeerSize() = oPeer.PreferredSize() + oControl.Time = NullValue + Else + If oControl.MaxTextLen > SBMAXTEXTSIZE Then + oControl.Text = Mid(SBSIZETEXT,1, SBMAXTEXTSIZE) + Else + oControl.Text = Mid(SBSIZETEXT,1, oControl.MaxTextLen) + End If + GetPeerSize() = oPeer.PreferredSize() + oControl.Text = "" + End If +End Function + + +Function TwipToCM(ByVal nValue as long) as String + TwipToCM = trim(str(nValue / 567)) + "cm" +End function + + +Function TwipTo100telMM(ByVal nValue as long) as long + TwipTo100telMM = nValue / 0.567 +End function + + +Function TwipToPixel(ByVal nValue as long) as long ' not an exact calculation + TwipToPixel = nValue / 15 +End function + + +Function PixelTo100thMMX(oControl as Object) as long + oPeer = oControl.GetPeer() + PixelTo100mmX = Clng(Peer.GetInfo.PixelPerMeterX/100000) + +' PixelTo100thMM = nValue * 28 ' not an exact calculation +End function + + +Function PixelTo100thMMY(oControl as Object) as long + oPeer = oControl.GetPeer() + PixelTo100mmX = Clng(Peer.GetInfo.PixelPerMeterY/100000) + +' PixelTo100thMM = nValue * 28 ' not an exact calculation +End function + + +Function GetPoint(xPos, YPos) as New com.sun.star.awt.Point +Dim aPoint as New com.sun.star.awt.Point + aPoint.X = xPos + aPoint.Y = yPos + GetPoint() = aPoint +End Function + + +Function GetSize(iWidth, iHeight) As New com.sun.star.awt.Size +Dim aSize As New com.sun.star.awt.Size + aSize.Width = iWidth + aSize.Height = iHeight + GetSize() = aSize +End Function + + +Sub ImportStyles() +Dim OldIndex as Integer + If Not bDebug Then + On Local Error GoTo WIZARDERROR + End If + OldIndex = CurIndex + CurIndex = GetCurIndex(DialogModel.lstStyles, Styles(),8) + If CurIndex <> OldIndex Then + ToggleLayoutPage(False) + Dim sImportPath as String + sImportPath = Styles(CurIndex, 8) + bWithBackGraphic = LoadNewStyles(oDocument, DialogModel, CurIndex, sImportPath, Styles(), TexturePath) + ControlCaptionsToStandardLayout() + ToggleLayoutPage(True, "lstStyles") + End If +WIZARDERROR: + If Err <> 0 Then + Msgbox(sMsgErrMsg, 16, GetProductName()) + Resume LOCERROR + LOCERROR: + End If +End Sub + + + +Function SetNumerics(ByVal oLocObject as Object, iLocFieldType as Integer) as Object + If CurControlType = cNumericBox Then + oLocObject.TreatAsNumber = True + Select Case iLocFieldType + Case com.sun.star.sdbc.DataType.BIGINT + oLocObject.EffectiveMax = 2147483647 * 2147483647 + oLocObject.EffectiveMin = -(-2147483648 * -2147483648) +' oLocObject.DecimalAccuracy = 0 + Case com.sun.star.sdbc.DataType.INTEGER + oLocObject.EffectiveMax = 2147483647 + oLocObject.EffectiveMin = -2147483648 + Case com.sun.star.sdbc.DataType.SMALLINT + oLocObject.EffectiveMax = 32767 + oLocObject.EffectiveMin = -32768 + Case com.sun.star.sdbc.DataType.TINYINT + oLocObject.EffectiveMax = 127 + oLocObject.EffectiveMin = -128 + Case com.sun.star.sdbc.DataType.FLOAT, com.sun.star.sdbc.DataType.REAL, com.sun.star.sdbc.DataType.DOUBLE, com.sun.star.sdbc.DataType.DECIMAL, com.sun.star.sdbc.DataType.NUMERIC +'Todo: oLocObject.DecimalAccuracy = ... + oLocObject.EffectiveDefault = CurDefaultValue +' Todo: HelpText??? + End Select + If oLocObject.PropertySetinfo.HasPropertyByName("Width")Then ' Note: an Access AutoincrementField does not provide this property Width + oLocObject.Width = CurFieldLength + CurScale + 1 + End If + If CurIsCurrency Then +'Todo: How do you set currencies? + End If + ElseIf CurControlType = cTextBox Then 'com.sun.star.sdbc.DataType.CHAR, com.sun.star.sdbc.DataType.VARCHAR, com.sun.star.sdbc.DataType.LONGVARCHAR + If CurFieldLength = 0 Then 'Or oLocObject.MaxTextLen > SBMAXTEXTSIZE + oLocObject.MaxTextLen = SBMAXTEXTSIZE + CurFieldLength = SBMAXTEXTSIZE + Else + oLocObject.MaxTextLen = CurFieldLength + End If + oLocObject.DefaultText = CurDefaultValue + ElseIf CurControlType = cDateBox Then +' Todo Why does this not work?: oLocObject.DefaultDate = CurDefaultValue + ElseIf CurControlType = cTimeBox Then ' com.sun.star.sdbc.DataType.DATE, com.sun.star.sdbc.DataType.TIME + oLocObject.DefaultTime = CurDefaultValue +' Todo: Property TimeFormat? from where? + ElseIf CurControlType = cCheckBox Then +' Todo Why does this not work?: oLocObject.DefaultState = CurDefaultValue + End If + If oLocObject.PropertySetInfo.HasPropertybyName("FormatKey") Then + On Local Error Resume Next + oLocObject.FormatKey = CurFormatKey + End If +End Function + + +' Destroy all Shapes in Nirwana +Sub RemoveShapes() +Dim n as Integer +Dim oControl as Object +Dim oShape as Object + For n = oDrawPage.Count-1 To 0 Step -1 + oShape = oDrawPage(n) + If oShape.Position.Y > -2000 Then + oDrawPage.Remove(oShape) + End If + Next n +End Sub + + +' Destroy all Shapes in Nirwana +Sub RemoveNirwanaShapes() +Dim n as Integer +Dim oControl as Object +Dim oShape as Object + For n = oDrawPage.Count-1 To 0 Step -1 + oShape = oDrawPage(n) + If oShape.Position.Y < -2000 Then + oDrawPage.Remove(oShape) + End If + Next n +End Sub + + + +' Note: as Shapes cannot be removed from the DrawPage without destroying +' the object we have to park them somewhere beyond the visible area of the page +Sub ShapesToNirwana() +Dim n as Integer +Dim oControl as Object + For n = 0 To oDrawPage.Count-1 + oDrawPage(n).Position = GetPoint(-20, -10000) + Next n +End Sub + + +Function CalcUniqueContentName(ByVal oContainer as Object, sBaseName as String) as String + +Dim nPostfix as Integer +Dim sReturn as String + nPostfix = 2 + sReturn = sBaseName + while (oContainer.hasByName(sReturn)) + sReturn = sBaseName & nPostfix + nPostfix = nPostfix + 1 + Wend + CalcUniqueContentName = sReturn +End Function + + +Function CountItemsInArray(BigArray(), SearchItem) +Dim i as Integer +Dim MaxIndex as Integer +Dim ResCount as Integer + ResCount = 0 + MaxIndex = Ubound(BigArray()) + For i = 0 To MaxIndex + If SearchItem = BigArray(i) Then + ResCount = ResCount + 1 + End If + Next i + CountItemsInArray() = ResCount +End Function + + +Function GetDBHeight(oDBModel as Object) + If CurControlType = cImageControl Then + nDBHeight = 2000 + Else + If CurFieldType = com.sun.star.sdbc.DataType.LONGVARCHAR Then + oDBModel.MultiLine = True + nDBHeight = nDBRefHeight * 4 + Else + nDBHeight = nDBRefHeight + End If + End If + GetDBHeight() = nDBHeight +End Function + + +Function GetFormWizardPaths() as Boolean + FormPath = GetOfficeSubPath("Template","../wizard/bitmap") + If FormPath <> "" Then + WizardPath = GetOfficeSubPath("Template","wizard/") + If Wizardpath <> "" Then + TexturePath = GetOfficeSubPath("Gallery", "backgrounds/") + If TexturePath <> "" Then + WorkPath = GetPathSettings("Work") + If WorkPath <> "" Then + TempPath = GetPathSettings("Temp") + If TempPath <> "" Then + GetFormWizardPaths = True + Exit Function + End If + End If + End If + End If + End If + DisposeDocument(oDocument) + GetFormWizardPaths() = False +End Function + + +Function GetFilterName(sApplicationKey as String) as String +Dim oArgs() +Dim oFactory +Dim i as Integer +Dim Maxindex as Integer +Dim UIName as String + oFactory = createUnoService("com.sun.star.document.FilterFactory") + oArgs() = oFactory.getByName(sApplicationKey) + MaxIndex = Ubound(oArgs()) + For i = 0 to MaxIndex + If (oArgs(i).Name="UIName") Then + UIName = oArgs(i).Value + Exit For + End If + next i + GetFilterName() = UIName +End Function + diff --git a/wizards/source/gimmicks/AutoText.xba b/wizards/source/gimmicks/AutoText.xba new file mode 100644 index 000000000..a25d1eed9 --- /dev/null +++ b/wizards/source/gimmicks/AutoText.xba @@ -0,0 +1,114 @@ + + + +' BASIC +Option Explicit +Dim oDocument as Object +Dim sDocumentTitle as String + + +Sub Main() +Dim oTable as Object +Dim oRows as Object +Dim oDocuText as Object +Dim oAutoTextCursor as Object +Dim oAutoTextContainer as Object +Dim oAutogroup as Object +Dim oAutoText as Object +Dim oCharStyles as Object +Dim oContentStyle as Object +Dim oHeaderStyle as Object +Dim oGroupTitleStyle as Object +Dim n, m, iAutoCount as Integer + BasicLibraries.LoadLibrary("Tools") + sDocumentTitle = "Installed AutoTexts" + + ' Open a new empty document + oDocument = CreateNewDocument("swriter") + If Not IsNull(oDocument) Then + oDocument.DocumentProperties.Title = sDocumentTitle + oDocuText = oDocument.Text + + ' Create The Character-templates + oCharStyles = oDocument.StyleFamilies.GetByName("CharacterStyles") + + ' The Characterstyle for the Header that describes the Title of Autotextgroups + oGroupTitleStyle = oDocument.createInstance("com.sun.star.style.CharacterStyle") + oCharStyles.InsertbyName("AutoTextGroupTitle", oGroupTitleStyle) + + oGroupTitleStyle.CharWeight = com.sun.star.awt.FontWeight.BOLD + oGroupTitleStyle.CharHeight = 14 + + ' The Characterstyle for the Header that describes the Title of Autotextgroups + oHeaderStyle = oDocument.createInstance("com.sun.star.style.CharacterStyle") + oCharStyles.InsertbyName("AutoTextHeading", oHeaderStyle) + oHeaderStyle.CharWeight = com.sun.star.awt.FontWeight.BOLD + + ' "Ordinary" Table Content + oContentStyle = oDocument.createInstance("com.sun.star.style.CharacterStyle") + oCharStyles.InsertbyName("TableContent", oContentStyle) + + oAutoTextContainer = CreateUnoService("com.sun.star.text.AutoTextContainer") + + oAutoTextCursor = oDocuText.CreateTextCursor() + + oAutoTextCursor.CharStyleName = "AutoTextGroupTitle" + ' Link the Title with the following table + oAutoTextCursor.ParaKeepTogether = True + + For n = 0 To oAutoTextContainer.Count - 1 + oAutoGroup = oAutoTextContainer.GetByIndex(n) + + oAutoTextCursor.SetString(oAutoGroup.Title) + oAutoTextCursor.CollapseToEnd() + oDocuText.insertControlCharacter(oAutoTextCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + oTable = oDocument.CreateInstance("com.sun.star.text.TextTable") + ' Divide the table if necessary + oTable.Split = True +' oTable.KeepTogether = False + oTable.RepeatHeadLine = True + oAutoTextCursor.Text.InsertTextContent(oAutoTextCursor,oTable,False) + InsertStringToCell("AutoText Name",oTable.GetCellbyPosition(0,0), "AutoTextHeading") + InsertStringToCell("AutoText Shortcut",oTable.GetCellbyPosition(1,0), "AutoTextHeading") + ' Insert one row at the bottom of the table + oRows = oTable.Rows + iAutoCount = oAutoGroup.Count + For m = 0 To iAutoCount-1 + ' Insert the name and the title of all Autotexts + oAutoText = oAutoGroup.GetByIndex(m) + InsertStringToCell(oAutoGroup.Titles(m), oTable.GetCellbyPosition(0, m + 1), "TableContent") + InsertStringToCell(oAutoGroup.ElementNames(m), oTable.GetCellbyPosition(1, m + 1), "TableContent") + If m < iAutoCount-1 Then + oRows.InsertbyIndex(m + 2,1) + End If + Next m + oDocuText.insertControlCharacter(oAutoTextCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + oAutoTextCursor.CollapseToEnd() + Next n + End If +End Sub + + +Sub InsertStringToCell(sCellString as String, oCell as Object, sCellStyle as String) +Dim oCellCursor as Object + oCellCursor = oCell.CreateTextCursor() + oCellCursor.CharStyleName = sCellStyle + oCell.Text.insertString(oCellCursor,sCellString,False) + oDocument.CurrentController.Select(oCellCursor) +End Sub diff --git a/wizards/source/gimmicks/ChangeAllChars.xba b/wizards/source/gimmicks/ChangeAllChars.xba new file mode 100644 index 000000000..cdcbc9623 --- /dev/null +++ b/wizards/source/gimmicks/ChangeAllChars.xba @@ -0,0 +1,92 @@ + + + +' This macro replaces all characters in a writer-document through "x" or "X" signs. +' It works on the currently activated document. +Private const UPPERREPLACECHAR = "X" +Private const LOWERREPLACECHAR = "x" + +Private MSGBOXTITLE +Private NOTSAVEDTEXT +Private WARNING + +Sub ChangeAllChars ' Change all chars in the active document +Dim oSheets, oPages as Object +Dim i as Integer +Const MBYES = 6 +Const MBABORT = 2 +Const MBNO = 7 + BasicLibraries.LoadLibrary("Tools") + MSGBOXTITLE = "Change All Characters to an '" & UPPERREPLACECHAR & "'" + NOTSAVEDTEXT = "This document has already been modified: All characters will be changed to an " & UPPERREPLACECHAR & "'. Should the document be saved now?" + WARNING = "This macro changes all characters and numbers to an '" & UPPERREPLACECHAR & "' in this document." + + On Local Error GoTo NODOCUMENT + oDocument = StarDesktop.ActiveFrame.Controller.Model + NODOCUMENT: + If Err <> 0 Then + Msgbox(WARNING & chr(13) & "First, activate a Writer document." , 16, GetProductName()) + Exit Sub + End If + On Local Error Goto 0 + + sDocType = GetDocumentType(oDocument) + + If oDocument.IsModified And oDocument.Url <> "" Then + Status = MsgBox(NOTSAVEDTEXT, 3+32, MSGBOXTITLE) + Select Case Status + Case MBYES + oDocument.Store + Case MBABORT, MBNO + End + End Select + Else + Status = MsgBox(WARNING, 3+32, MSGBOXTITLE) + If Status = MBNO Or Status = MBABORT Then ' No, Abort + End + End If + End If + + Select Case sDocType + Case "swriter" + ReplaceAllStrings(oDocument) + + Case Else + Msgbox("This macro only works with Writer documents.", 16, GetProductName()) + End Select +End Sub + + +Sub ReplaceAllStrings(oContainer as Object) + ReplaceStrings(oContainer, "[a-z]", LOWERREPLACECHAR) + ReplaceStrings(oContainer, "[à-þ]", LOWERREPLACECHAR) + ReplaceStrings(oContainer, "[A-Z]", UPPERREPLACECHAR) + ReplaceStrings(oContainer, "[À-ß]", UPPERREPLACECHAR) + ReplaceStrings(oContainer, "[0-9]", UPPERREPLACECHAR) +End Sub + + +Sub ReplaceStrings(oContainer as Object, sSearchString, sReplaceString as String) + oReplaceDesc = oContainer.createReplaceDescriptor() + oReplaceDesc.SearchCaseSensitive = True + oReplaceDesc.SearchRegularExpression = True + oReplaceDesc.Searchstring = sSearchString + oReplaceDesc.ReplaceString = sReplaceString + oReplCount = oContainer.ReplaceAll(oReplaceDesc) +End Sub diff --git a/wizards/source/gimmicks/GetTexts.xba b/wizards/source/gimmicks/GetTexts.xba new file mode 100644 index 000000000..af93738fd --- /dev/null +++ b/wizards/source/gimmicks/GetTexts.xba @@ -0,0 +1,536 @@ + + + +Option Explicit +' Description: +' This macro extracts the strings out of the currently active document and inserts them into a log document. +' The aim of the macro is to provide the programmer an insight into the OpenOffice API. +' It focuses on how document objects are accessed. +' Therefore not only texts of the document body are retrieved but also texts of general +' document objects like, annotations, charts and general document information. + +Public oLogDocument, oLogText, oLogCursor, oLogHeaderStyle, oLogBodyTextStyle as Object +Public oDocument as Object +Public LogArray(1000) as String +Public LogIndex as Integer +Public oLocHeaderStyle as Object + +Sub Main +Dim sDocType as String +Dim oHyperCursor as Object +Dim oCharStyles as Object + BasicLibraries.LoadLibrary("Tools") + On Local Error GoTo NODOCUMENT + oDocument = StarDesktop.ActiveFrame.Controller.Model + sDocType = GetDocumentType(oDocument) + NODOCUMENT: + If Err <> 0 Then + Msgbox("This macro extracts all data from the active Writer, Calc or Draw/Impress document." & chr(13) &_ + "To start this macro you have to activate a document first." , 16, GetProductName) + Exit Sub + End If + On Local Error Goto 0 + + ' Open a new document where all the texts are inserted + oLogDocument = CreateNewDocument("swriter") + If Not IsNull(oLogDocument) Then + oLogText = oLogDocument.Text + + ' create and define the character styles of the log document + oCharStyles = oLogDocument.StyleFamilies.GetByName("CharacterStyles") + oLogHeaderStyle = oLogDocument.createInstance("com.sun.star.style.CharacterStyle") + oCharStyles.InsertbyName("Log Header", oLogHeaderStyle) + + oLogHeaderStyle.charWeight = com.sun.star.awt.FontWeight.BOLD + oLogBodyTextStyle = oLogDocument.createInstance("com.sun.star.style.CharacterStyle") + oCharStyles.InsertbyName("Log Body", oLogBodyTextStyle) + + ' Insert the title of the activated document as a hyperlink + oHyperCursor = oLogText.createTextCursor() + oHyperCursor.CharWeight = com.sun.star.awt.FontWeight.BOLD + oHyperCursor.gotoStart(False) + oHyperCursor.HyperLinkURL = oDocument.URL + oHyperCursor.HyperLinkTarget = oDocument.URL + If oDocument.DocumentProperties.Title <> "" Then + oHyperCursor.HyperlinkName = oDocument.DocumentProperties.Title + End If + oLogText.insertString(oHyperCursor, oDocument.DocumentProperties.Title, False) + oLogText.insertControlCharacter(oHyperCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + + oLogCursor = oLogText.createTextCursor() + oLogCursor.GotoEnd(False) + ' "Switch off" the Hyperlink - Properties + oLogCursor.SetPropertyToDefault("HyperLinkURL") + oLogCursor.SetPropertyToDefault("HyperLinkTarget") + oLogCursor.SetPropertyToDefault("HyperLinkName") + LogIndex = 0 + + ' Get the Properties of the document + GetDocumentProps() + + Select Case sDocType + Case "swriter" + GetWriterStrings() + Case "scalc" + GetCalcStrings() + Case "sdraw", "simpress" + GetDrawStrings() + Case Else + Msgbox("This macro only works with a Writer, Calc or Draw/Impress document.", 16, GetProductName()) + End Select + End If +End Sub + + +' ***********************************************Calc documents************************************************** + +Sub GetCalcStrings() +Dim i, n as integer +Dim oSheet as Object +Dim SheetName as String +Dim oSheets as Object + ' Create a sequence of all sheets within the document + oSheets = oDocument.Sheets + + For i = 0 to osheets.Count - 1 + oSheet = osheets.GetbyIndex(i) + SheetName = oSheet.Name + MakeLogHeadLine("Sheet No. " & i & " (" & SheetName & ")" ) + + ' Check the "body" of the sheet + GetCellTexts(oSheet) + + If oSheet.IsScenario then + MakeLogHeadLine("Scenario Comments from " & SheetName & "'") + WriteStringtoLogFile(osheet.ScenarioComment) + End if + + GetAnnotations(oSheet, "Annotations from '" & SheetName & "'") + + GetChartStrings(oSheet, "Charts from '" & SheetName & "'") + + GetControlStrings(oSheet.DrawPage, "Controls from '" & SheetName & "'") + Next + + ' Pictures + GetCalcGraphicNames() + + GetNamedRanges() +End Sub + + +Sub GetCellTexts(oSheet as Object) +Dim BigRange, BigEnum, oCell as Object + BigRange = oDocument.CreateInstance("com.sun.star.sheet.SheetCellRanges") + BigRange.InsertbyName("",oSheet) + BigEnum = BigRange.GetCells.CreateEnumeration + While BigEnum.hasmoreElements + oCell = BigEnum.NextElement + If oCell.String <> "" And Val(oCell.String) = 0then + WriteStringtoLogFile(oCell.String) + End If + Wend +End Sub + + +Sub GetAnnotations(oSheet as Object, HeaderLine as String) +Dim oNotes as Object +Dim n as Integer + oNotes = oSheet.getAnnotations + If oNotes.hasElements() then + MakeLogHeadLine(HeaderLine) + For n = 0 to oNotes.Count-1 + WriteStringtoLogFile(oNotes.GetbyIndex(n).String) + Next + End if +End Sub + + +Sub GetNamedRanges() +Dim i as integer + MakeLogHeadLine("Named Ranges") + For i = 0 To oDocument.NamedRanges.Count - 1 + WriteStringtoLogFile(oDocument.NamedRanges.GetbyIndex(i).Name) + Next +End Sub + + +Sub GetCalcGraphicNames() +Dim n,m as integer + MakeLogHeadLine("Graphics") + For n = 0 To oDocument.Drawpages.count-1 + For m = 0 To oDocument.Drawpages.GetbyIndex(n).Count - 1 + WriteStringtoLogFile(oDocument.DrawPages.GetbyIndex(n).GetbyIndex(m).Text.String) + Next m + Next n +End Sub + + +' ***********************************************Writer documents************************************************** + +Sub GetParagraphTexts(oParaObject as Object, HeadLine as String) +Dim ParaEnum as Object +Dim oPara as Object +Dim oTextPortEnum as Object +Dim oTextPortion as Object +Dim i as integer +Dim oCellNames() +Dim oCell as Object + + MakeLogHeadLine(HeadLine) + ParaEnum = oParaObject.Text.CreateEnumeration + + While ParaEnum.HasMoreElements + oPara = ParaEnum.NextElement + + ' Note: The enumeration ParaEnum lists all tables and paragraphs. + ' Therefore we have to find out what kind of object "oPara" actually is + If oPara.supportsService("com.sun.star.text.Paragraph") Then + ' "oPara" is a Paragraph + oTextPortEnum = oPara.createEnumeration + While oTextPortEnum.hasmoreElements + oTextPortion = oTextPortEnum.nextElement() + WriteStringToLogFile(oTextPortion.String) + Wend + Else + ' "oPara" is a table + oCellNames = oPara.CellNames + For i = 0 To Ubound(oCellNames()) + If oCellNames(i) <> "" Then + oCell = oPara.getCellByName(oCellNames(i)) + WriteStringToLogFile(oCell.String) + End If + Next + End If + Wend +End Sub + + +Sub GetChartStrings(oSheet as Object, HeaderLine as String) +Dim i as Integer +Dim aChartObject as Object +Dim aChartDiagram as Object + + MakeLogHeadLine(HeaderLine) + + For i = 0 to oSheet.Charts.Count-1 + aChartObject = oSheet.Charts.GetByIndex(i).EmbeddedObject + If aChartObject.HasSubTitle then + WriteStringToLogFile(aChartObject.SubTitle.String) + End If + + If aChartObject.HasMainTitle then + WriteStringToLogFile(aChartObject.Title.String) + End If + + aChartDiagram = aChartObject.Diagram + + If aChartDiagram.hasXAxisTitle Then + WriteStringToLogFile(aChartDiagram.XAxisTitle) + End If + + If aChartDiagram.hasYAxisTitle Then + WriteStringToLogFile(aChartDiagram.YAxisTitle) + End If + + If aChartDiagram.hasZAxisTitle Then + WriteStringToLogFile(aChartDiagram.ZAxisTitle) + End If + Next i +End Sub + + +Sub GetFrameTexts() +Dim i as integer +Dim oTextFrame as object +Dim oFrameEnum as Object +Dim oFramePort as Object +Dim oFrameTextEnum as Object +Dim oFrameTextPort as Object + + MakeLogHeadLine("Text Frames") + For i = 0 to oDocument.TextFrames.Count-1 + oTextFrame = oDocument.TextFrames.GetbyIndex(i) + WriteStringToLogFile(oTextFrame.Name) + + ' Is the frame bound to the page? + If oTextFrame.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE Then + GetParagraphTexts(oTextFrame, "Text Frame Contents") + End If + + oFrameEnum = oTextFrame.CreateEnumeration + While oFrameEnum.HasMoreElements + oFramePort = oFrameEnum.NextElement + If oFramePort.supportsService("com.sun.star.text.Paragraph") then + oFrameTextEnum = oFramePort.createEnumeration + While oFrameTextEnum.HasMoreElements + oFrameTextPort = oFrameTextEnum.NextElement + If oFrameTextPort.SupportsService("com.sun.star.text.TextFrame") Then + WriteStringtoLogFile(oFrameTextPort.String) + End If + Wend + Else + WriteStringtoLogFile(oFramePort.Name) + End if + Wend + Next +End Sub + + +Sub GetTextFieldStrings() +Dim aTextField as Object +Dim i as integer +Dim CurElement as Object + MakeLogHeadLine("Text Fields") + aTextfield = oDocument.getTextfields.CreateEnumeration + While aTextField.hasmoreElements + CurElement = aTextField.NextElement + If CurElement.PropertySetInfo.hasPropertybyName("Content") Then + WriteStringtoLogFile(CurElement.Content) + ElseIf CurElement.PropertySetInfo.hasPropertybyName("PlaceHolder") Then + WriteStringtoLogFile(CurElement.PlaceHolder) + WriteStringtoLogFile(CurElement.Hint) + ElseIf Curelement.TextFieldMaster.PropertySetInfo.HasPropertybyName("Content") then + WriteStringtoLogFile(CurElement.TextFieldMaster.Content) + End If + Wend +End Sub + + +Sub GetLinkedFileNames() +Dim oDocSections as Object +Dim LinkedFileName as String +Dim i as Integer + If Right(oDocument.URL,3) = "sgl" Then + MakeLogHeadLine("Sub-documents") + oDocSections = oDocument.TextSections + For i = 0 to oDocSections.Count - 1 + LinkedFileName = oDocSections.GetbyIndex(i).FileLink.FileURL + If LinkedFileName <> "" Then + WriteStringToLogFile(LinkedFileName) + End If + Next i + End If +End Sub + + +Sub GetSectionNames() +Dim i as integer +Dim oDocSections as Object + MakeLogHeadLine("Sections") + oDocSections = oDocument.TextSections + For i = 0 to oDocSections.Count-1 + WriteStringtoLogFile(oDocSections.GetbyIndex(i).Name) + Next +End Sub + + +Sub GetWriterStrings() + GetParagraphTexts(oDocument, "Document Body") + GetGraphicNames() + GetStyles() + GetControlStrings(oDocument.DrawPage, "Controls") + GetTextFieldStrings() + GetSectionNames() + GetFrameTexts() + GetHyperLinks + GetLinkedFileNames() +End Sub + + +' ***********************************************Draw/Impress documents************************************************** + +Sub GetDrawPageTitles(LocObject as Object) +Dim n as integer +Dim oPage as Object + + For n = 0 to LocObject.Count - 1 + oPage = LocObject.GetbyIndex(n) + WriteStringtoLogFile(oPage.Name) + ' Is the page a DrawPage and not a MasterPage? + If oPage.supportsService("com.sun.star.drawing.DrawPage")then + ' Get the name of the NotesPage (only relevant for Impress documents) + If oDocument.supportsService("com.sun.star.presentation.PresentationDocument") then + WriteStringtoLogFile(oPage.NotesPage.Name) + End If + End If + Next +End Sub + + +Sub GetPageStrings(oPages as Object) +Dim m, n, s as Integer +Dim oPage, oPageElement, oShape as Object + For n = 0 to oPages.Count-1 + oPage = oPages.GetbyIndex(n) + If oPage.HasElements then + For m = 0 to oPage.Count-1 + oPageElement = oPage.GetByIndex(m) + If HasUnoInterfaces(oPageElement,"com.sun.star.container.XIndexAccess") Then + ' The Object "oPageElement" a group of Shapes, that can be accessed by their index + For s = 0 To oPageElement.Count - 1 + WriteStringToLogFile(oPageElement.GetByIndex(s).String) + Next s + ElseIf HasUnoInterfaces(oPageElement, "com.sun.star.text.XText") Then + WriteStringtoLogFile(oPageElement.String) + End If + Next + End If + Next +End Sub + + +Sub GetDrawStrings() +Dim oDPages, oMPages as Object + + oDPages = oDocument.DrawPages + oMPages = oDocument.Masterpages + + MakeLogHeadLine("Titles") + GetDrawPageTitles(oDPages) + GetDrawPageTitles(oMPages) + + MakeLogHeadLine("Document Body") + GetPageStrings(oDPages) + GetPageStrings(oMPages) +End Sub + + +' ***********************************************Misc************************************************** + +Sub GetDocumentProps() +Dim oDocuProps as Object + MakeLogHeadLine("Document Properties") + oDocuProps = oDocument.DocumentProperties + WriteStringToLogFile(oDocuProps.Title) + WriteStringToLogFile(oDocuProps.Description) + WriteStringToLogFile(oDocuProps.Subject) + WriteStringToLogFile(oDocuProps.Author) + ' WriteStringToLogFile(oDocuProps.UserDefinedProperties.ReplyTo) + ' WriteStringToLogFile(oDocuProps.UserDefinedProperties.Recipient) + ' WriteStringToLogFile(oDocuProps.UserDefinedProperties.References) + ' WriteStringToLogFile(oDocuProps.Keywords) +End Sub + + +Sub GetHyperlinks() +Dim i as integer +Dim oCrsr as Object +Dim oAllHyperLinks as Object +Dim SrchAttributes(0) as new com.sun.star.beans.PropertyValue +Dim oSearchDesc as Object + + MakeLogHeadLine("Hyperlinks") + ' create a Search-Descriptor + oSearchDesc = oDocument.CreateSearchDescriptor + oSearchDesc.Valuesearch = False + + ' define the Search-attributes + srchattributes(0).Name = "HyperLinkURL" + srchattributes(0).Value = "" + oSearchDesc.SetSearchAttributes(SrchAttributes()) + + oAllHyperLinks = oDocument.findAll(oSearchDesc()) + + For i = 0 to oAllHyperLinks.Count - 1 + oFound = oAllHyperLinks(i) + oCrsr = oFound.Text.createTextCursorByRange(oFound) + WriteStringToLogFile(oCrs.HyperLinkURL) 'Url + WriteStringToLogFile(oCrs.HyperLinkTarget) 'Name + WriteStringToLogFile(oCrs.HyperLinkName) 'Frame + Next i +End Sub + + +Sub GetGraphicNames() +Dim i as integer +Dim oDocGraphics as Object + MakeLogHeadLine("Graphics") + oDocGraphics = oDocument.GraphicObjects + For i = 0 to oDocGraphics.count - 1 + WriteStringtoLogFile(oDocGraphics.GetbyIndex(i).Name) + Next +End Sub + + +Sub GetStyles() +Dim m,n as integer + MakeLogHeadLine("User-defined Templates") + + ' Check all StyleFamilies(i.e. PageStyles, ParagraphStyles, CharacterStyles, cellStyles) + For n = 0 to oDocument.StyleFamilies.Count - 1 + For m = 0 to oDocument.StyleFamilies.getbyIndex(n).Count-1 + If oDocument.StyleFamilies.GetbyIndex(n).getbyIndex(m).IsUserDefined then + WriteStringtoLogFile(oDocument.StyleFamilies.GetbyIndex(n).getbyIndex(m).Name) + End If + Next + Next +End Sub + + +Sub GetControlStrings(oDPage as Object, HeaderLine as String) +Dim aForm as Object +Dim m,n as integer + MakeLogHeadLine(HeaderLine) + 'SearchFor all possible Controls + For n = 0 to oDPage.Forms.Count - 1 + aForm = oDPage.Forms(n) + For m = 0 to aForm.Count-1 + GetControlContent(aForm.GetbyIndex(m)) + Next + Next +End Sub + + +Sub GetControlContent(LocControl as Object) +Dim i as integer + + If LocControl.PropertySetInfo.HasPropertybyName("Label") then + WriteStringtoLogFile(LocControl.Label) + + ElseIf LocControl.SupportsService("com.sun.star.form.component.ListBox") then + For i = 0 to Ubound(LocControl.StringItemList()) + WriteStringtoLogFile(LocControl.StringItemList(i)) + Next + End If + If LocControl.PropertySetInfo.HasPropertybyName("HelpText") then + WriteStringtoLogFile(LocControl.Helptext) + End If +End Sub + +' ***********************************************Log document************************************************** + +Sub WriteStringtoLogFile( sString as String) + If (Not FieldInArray(LogArray(),LogIndex,sString))AND (NOT ISNULL(sString)) Then + LogArray(LogIndex) = sString + LogIndex = LogIndex + 1 + oLogText.insertString(oLogCursor,sString,False) + oLogText.insertControlCharacter(oLogCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + End If +End Sub + + +Sub MakeLogHeadLine(HeadText as String) + oLogCursor.CharStyleName = "Log Header" + oLogText.insertControlCharacter(oLogCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + oLogText.insertString(oLogCursor,HeadText,False) + oLogText.insertControlCharacter(oLogCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + oLogCursor.CharStyleName = "Log Body" +End Sub + diff --git a/wizards/source/gimmicks/ReadDir.xba b/wizards/source/gimmicks/ReadDir.xba new file mode 100644 index 000000000..b60469508 --- /dev/null +++ b/wizards/source/gimmicks/ReadDir.xba @@ -0,0 +1,322 @@ + + + +Option Explicit +Public Const SBPAGEX = 800 +Public Const SBPAGEY = 800 +Public Const SBRELDIST = 1.3 + +' Names of the second Dimension of the Array iLevelPos +Public Const SBBASEX = 0 +Public Const SBBASEY = 1 + +Public Const SBOLDSTARTX = 2 +Public Const SBOLDSTARTY = 3 + +Public Const SBOLDENDX = 4 +Public Const SBOLDENDY = 5 + +Public Const SBNEWSTARTX = 6 +Public Const SBNEWSTARTY = 7 + +Public Const SBNEWENDX = 8 +Public Const SBNEWENDY = 9 + +Public ConnectLevel As Integer +Public iLevelPos(1,9) As Long +Public Source as String +Public iCurLevel as Integer +Public nConnectLevel as Integer +Public nOldWidth, nOldHeight As Long +Public nOldX, nOldY, nOldLevel As Integer +Public oOldLeavingLine As Object +Public oOldArrivingLine As Object +Public DlgReadDir as Object +Dim oProgressBar as Object +Dim oDocument As Object +Dim oPage As Object + + +Sub Main() +Dim oStandardTemplate as Object + BasicLibraries.LoadLibrary("Tools") + oDocument = CreateNewDocument("sdraw") + If Not IsNull(oDocument) Then + oPage = oDocument.DrawPages(0) + oStandardTemplate = oDocument.StyleFamilies.GetByName("graphics").GetByName("standard") + oStandardTemplate.CharHeight = 10 + oStandardTemplate.TextLeftDistance = 100 + oStandardTemplate.TextRightDistance = 100 + oStandardTemplate.TextUpperDistance = 50 + oStandardTemplate.TextLowerDistance = 50 + DlgReadDir = LoadDialog("Gimmicks","ReadFolderDlg") + oProgressBar = DlgReadDir.Model.ProgressBar1 + DlgReadDir.Model.TextField1.Text = ConvertFromUrl(GetPathSettings("Work")) + DlgReadDir.Model.cmdGoOn.DefaultButton = True + DlgReadDir.GetControl("TextField1").SetFocus() + DlgReadDir.Execute + End If +End Sub + + +Sub TreeInfo() +Dim oCurTextShape As Object +Dim i as Integer +Dim bStartUpRun As Boolean +Dim CurFilename as String +Dim BaseLevel as Integer +Dim oController as Object +Dim MaxFileIndex as Integer +Dim FileNames() as String + ToggleDialogControls(False) + oProgressBar.ProgressValueMin = 0 + oProgressBar.ProgressValueMax = 100 + bStartUpRun = True + nOldHeight = 200 + nOldY = SBPAGEY + nOldX = SBPAGEX + nOldWidth = SBPAGEX + oController = oDocument.GetCurrentController + Source = ConvertToURL(DlgReadDir.Model.TextField1.Text) + BaseLevel = CountCharsInString(Source, "/", 1) + oProgressBar.ProgressValue = 5 + DlgReadDir.Model.Label3.Enabled = True + FileNames() = ReadSourceDirectory(Source) + DlgReadDir.Model.Label4.Enabled = True + DlgReadDir.Model.Label3.Enabled = False + oProgressBar.ProgressValue = 12 + FileNames() = BubbleSortList(FileNames()) + DlgReadDir.Model.Label5.Enabled = True + DlgReadDir.Model.Label4.Enabled = False + oProgressBar.ProgressValue = 20 + MaxFileIndex = Ubound(FileNames(),1) + For i = 0 To MaxFileIndex + oProgressBar.ProgressValue = 20 + (i/MaxFileIndex * 80) + CurFilename = FileNames(i,1) + SetNewLevels(FileNames(i,0), BaseLevel) + oCurTextShape = CreateTextShape(oPage, CurFilename) + CheckPageWidth(oCurTextShape.Size.Width) + iLevelPos(iCurLevel,SBBASEY) = oCurTextShape.Position.Y + If i = 0 Then + AdjustPageHeight(oCurTextShape.Size.Height, MaxFileIndex + 1) + End If + ' The Current TextShape has To be connected with a TextShape one Level higher + ' except for a TextShape In Level 0: + If Not bStartUpRun Then + ' A leaving Line Is only drawn when level is not 0 + If iCurLevel<> 0 Then + ' Determine the Coordinates of the arriving Line + iLevelPos(iCurLevel,SBOLDSTARTX) = iLevelPos(nConnectLevel,SBNEWSTARTX) + iLevelPos(iCurLevel,SBOLDSTARTY) = oCurTextShape.Position.Y + 0.5 * oCurTextShape.Size.Height + + iLevelPos(iCurLevel,SBOLDENDX) = iLevelPos(iCurLevel,SBBASEX) + iLevelPos(iCurLevel,SBOLDENDY) = oCurTextShape.Position.Y + 0.5 * oCurTextShape.Size.Height + + oOldArrivingLine = DrawLine(iCurLevel, SBOLDSTARTX, SBOLDSTARTY, SBOLDENDX, SBOLDENDY, oPage) + + ' Determine the End-Coordinates of the last leaving Line + iLevelPos(nConnectLevel,SBNEWENDX) = iLevelPos(nConnectLevel,SBNEWSTARTX) + iLevelPos(nConnectLevel,SBNEWENDY) = oCurTextShape.Position.Y + 0.5 * oCurTextShape.Size.Height + Else + ' On Level 0 the last Leaving Line's Endpoint is the upper edge of the TextShape + iLevelPos(nConnectLevel,SBNEWENDY) = oCurTextShape.Position.Y + iLevelPos(nConnectLevel,SBNEWENDX) = iLevelPos(nConnectLevel,SBNEWSTARTX) + End If + ' Draw the Connectors To the previous TextShapes + oOldLeavingLine = DrawLine(nConnectLevel, SBNEWSTARTX, SBNEWSTARTY, SBNEWENDX, SBNEWENDY, oPage) + Else + ' StartingPoint of the leaving Edge + bStartUpRun = FALSE + End If + + ' Determine the beginning Coordinates of the leaving Line + iLevelPos(iCurLevel,SBNEWSTARTX) = iLevelPos(iCurLevel,SBBASEX) + 0.5 * oCurTextShape.Size.Width + iLevelPos(iCurLevel,SBNEWSTARTY) = iLevelPos(iCurLevel,SBBASEY) + oCurTextShape.Size.Height + + ' Save the values For the Next run + nOldHeight = oCurTextShape.Size.Height + nOldX = oCurTextShape.Position.X + nOldWidth = oCurTextShape.Size.Width + nOldLevel = iCurLevel + Next i + ToggleDialogControls(True) + DlgReadDir.Model.cmdGoOn.Enabled = False +End Sub + + +Function CreateTextShape(oPage as Object, Filename as String) +Dim oTextShape As Object +Dim aPoint As New com.sun.star.awt.Point + + aPoint.X = CalculateXPoint() + aPoint.Y = nOldY + SBRELDIST * nOldHeight + nOldY = aPoint.Y + + oTextShape = oDocument.createInstance("com.sun.star.drawing.TextShape") + oTextShape.LineStyle = 1 + oTextShape.Position = aPoint + + oPage.add(oTextShape) + oTextShape.TextAutoGrowWidth = TRUE + oTextShape.TextAutoGrowHeight = TRUE + oTextShape.String = FileName + + ' Configure Size And Position of the TextShape according to its Scripting + aPoint.X = iLevelPos(iCurLevel,SBBASEX) + oTextShape.Position = aPoint + CreateTextShape() = oTextShape +End Function + + +Function CalculateXPoint() + ' The current level Is lower than the Old one + If (iCurLevel< nOldLevel) And (iCurLevel<> 0) Then + ' ClearArray(iLevelPos(),iCurLevel+1) + Elseif iCurLevel= 0 Then + iLevelPos(iCurLevel,SBBASEX) = SBPAGEX + ' The current level Is higher than the old one + Elseif iCurLevel> nOldLevel Then + iLevelPos(iCurLevel,SBBASEX) = iLevelPos(iCurLevel-1,SBBASEX) + nOldWidth + 100 + End If + CalculateXPoint = iLevelPos(iCurLevel,SBBASEX) +End Function + + +Function DrawLine(nLevel, nStartX, nStartY, nEndX, nEndY As Integer, oPage as Object) +Dim oConnect As Object +Dim aPoint As New com.sun.star.awt.Point +Dim aSize As New com.sun.star.awt.Size + aPoint.X = iLevelPos(nLevel,nStartX) + aPoint.Y = iLevelPos(nLevel,nStartY) + aSize.Width = iLevelPos(nLevel,nEndX) - iLevelPos(nLevel,nStartX) + aSize.Height = iLevelPos(nLevel,nEndY) - iLevelPos(nLevel,nStartY) + oConnect = oDocument.createInstance("com.sun.star.drawing.LineShape") + oConnect.Position = aPoint + oConnect.Size = aSize + oPage.Add(oConnect) + DrawLine() = oConnect +End Function + + +Sub GetSourceDirectory() + GetFolderName(DlgReadDir.Model.TextField1) +End Sub + + +Function ReadSourceDirectory(ByVal Source As String) +Dim i as Integer +Dim m as Integer +Dim n as Integer +Dim s as integer +Dim FileName as string +Dim FileNameList(100,1) as String +Dim DirList(0) as String +Dim oUCBobject as Object +Dim DirContent() as String +Dim SystemPath as String +Dim PathSeparator as String +Dim MaxFileIndex as Integer + PathSeparator = GetPathSeparator() + oUcbobject = createUnoService("com.sun.star.ucb.SimpleFileAccess") + m = 0 + s = 0 + DirList(0) = Source + FileNameList(n,0) = Source + SystemPath = ConvertFromUrl(Source) + FileNameList(n,1) = FileNameoutofPath(SystemPath, PathSeparator) + n = 1 + Do + Source = DirList(m) + m = m + 1 + DirContent() = oUcbObject.GetFolderContents(Source,True) + If Ubound(DirContent()) <> -1 Then + MaxFileIndex = Ubound(DirContent()) + For i = 0 to MaxFileIndex + FileName = DirContent(i) + FileNameList(n,0) = FileName + SystemPath = ConvertFromUrl(FileName) + FileNameList(n,1) = FileNameOutofPath(SystemPath, PathSeparator) + n = n + 1 + If n > Ubound(FileNameList(),1) Then + ReDim Preserve FileNameList(n + 10,1) as String + End If + If oUcbObject.IsFolder(FileName) Then + s = s + 1 + ReDim Preserve DirList(s) as String + DirList(s) = FileName + End If + Next i + End If + Loop Until m > Ubound(DirList()) + ReDim Preserve FileNameList(n-1,1) as String + ReadSourceDirectory() = FileNameList() +End Function + + +Sub CloseDialog + DlgReadDir.EndExecute +End Sub + + +Sub AdjustPageHeight(lShapeHeight, FileCount) +Dim lNecHeight as Long +Dim lBorders as Long + oDocument.LockControllers + lBorders = oPage.BorderTop + oPage.BorderBottom + lNecHeight = SBPAGEY + (FileCount * SBRELDIST * lShapeHeight) + If lNecHeight > (oPage.Height - lBorders) Then + oPage.Height = lNecHeight + lBorders + 500 + End If + oDocument.UnlockControllers +End Sub + + +Sub SetNewLevels(FileName as String, BaseLevel as Integer) + iCurLevel= CountCharsInString(FileName, "/", 1) - BaseLevel + If iCurLevel <> 0 Then + nConnectLevel = iCurLevel- 1 + Else + nConnectLevel = iCurLevel + End If + If iCurLevel > Ubound(iLevelPos(),1) Then + ReDim Preserve iLevelPos(iCurLevel,9) as Long + End If +End Sub + + +Sub CheckPageWidth(TextWidth as Long) +Dim PageWidth as Long +Dim BaseX as Long + PageWidth = oPage.Width + BaseX = iLevelPos(iCurLevel,SBBASEX) + If BaseX + TextWidth > PageWidth - 1000 Then + oPage.Width = 1000 + BaseX + TextWidth + End If +End Sub + + +Sub ToggleDialogControls(bDoEnable as Boolean) + With DlgReadDir.Model + .cmdGoOn.Enabled = bDoEnable + .cmdGetDir.Enabled = bDoEnable + .Label1.Enabled = bDoEnable + .Label2.Enabled = bDoEnable + .TextField1.Enabled = bDoEnable + End With +End Sub diff --git a/wizards/source/gimmicks/ReadFolderDlg.xdl b/wizards/source/gimmicks/ReadFolderDlg.xdl new file mode 100644 index 000000000..797e97755 --- /dev/null +++ b/wizards/source/gimmicks/ReadFolderDlg.xdl @@ -0,0 +1,39 @@ + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/gimmicks/UserfieldDlg.xdl b/wizards/source/gimmicks/UserfieldDlg.xdl new file mode 100644 index 000000000..efa0eff7e --- /dev/null +++ b/wizards/source/gimmicks/UserfieldDlg.xdl @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/gimmicks/Userfields.xba b/wizards/source/gimmicks/Userfields.xba new file mode 100644 index 000000000..17426cb49 --- /dev/null +++ b/wizards/source/gimmicks/Userfields.xba @@ -0,0 +1,236 @@ + + + +Option Explicit +'Todo: Controlling Scrollbar via Keyboard + +Public Const SBMAXFIELDINDEX = 14 + +Public DlgUserFields as Object +Public oDocument as Object +Public UserFieldDataType(SBMAXFIELDINDEX,1) as String +Public ScrollBarValue as Integer +Public UserFieldFamily(0, SBMAXfIELDINDEX) as String +Public Const SBTBCOUNT = 9 +Public oUserDataAccess as Object +Public CurFieldIndex as Integer +Public FilePath as String + +Sub StartChangesUserfields +Dim SystemPath as String + BasicLibraries.LoadLibrary("Tools") + UserFieldDatatype(0,0) = "COMPANY" + UserFieldDatatype(0,1) = "o" + UserFieldDatatype(1,0) = "FIRSTNAME" + UserFieldDatatype(1,1) = "givenname" + UserFieldDatatype(2,0) = "LASTNAME" + UserFieldDatatype(2,1) = "sn" + UserFieldDatatype(3,0) = "INITIALS" + UserFieldDatatype(3,1) = "initials" + UserFieldDatatype(4,0) = "STREET" + UserFieldDatatype(4,1) = "street" + UserFieldDatatype(5,0) = "COUNTRY" + UserFieldDatatype(5,1) = "c" + UserFieldDatatype(6,0) = "ZIP" + UserFieldDatatype(6,1) = "postalcode" + UserFieldDatatype(7,0) = "CITY" + UserFieldDatatype(7,1) = "l" + UserFieldDatatype(8,0) = "TITLE" + UserFieldDatatype(8,1) = "title" + UserFieldDatatype(9,0) = "POSITION" + UserFieldDatatype(9,1) = "position" + UserFieldDatatype(10,0) = "PHONE_HOME" + UserFieldDatatype(10,1) = "homephone" + UserFieldDatatype(11,0) = "PHONE_WORK" + UserFieldDatatype(11,1) = "telephonenumber" + UserFieldDatatype(12,0) = "FAX" + UserFieldDatatype(12,1) = "facsimiletelephonenumber" + UserFieldDatatype(13,0) = "E-MAIL" + UserFieldDatatype(13,1) = "mail" + UserFieldDatatype(14,0) = "STATE" + UserFieldDatatype(14,1) = "st" + FilePath = GetPathSettings("Config", False) & "/" & "UserData.dat" + DlgUserFields = LoadDialog("Gimmicks","UserfieldDlg") + SystemPath = ConvertFromUrl(FilePath) + DlgUserFields.Model.Label10.Label = ReplaceString(DlgUserFields.Model.Label10.Label, "'" & SystemPath & "'", "<ConfigDir>") + DlgUserFields.Model.Label10.Label = ReplaceString(DlgUserFields.Model.Label10.Label, GetProductName(), "<PRODUCTNAME>") + DlgUserFields.Model.cmdSelect.HelpText = ReplaceString(DlgUserFields.Model.cmdSelect.HelpText, GetProductName(), "<PRODUCTNAME>") + ScrollBarValue = 0 + oUserDataAccess = GetRegistryKeyContent("org.openoffice.UserProfile/Data", True) + InitializeUserFamily() + FillDialog() + DlgUserFields.Execute + DlgUserFields.Dispose() +End Sub + + +Sub FillDialog() +Dim a as Integer + With DlgUserFields + For a = 1 To SBTBCount + .GetControl("Label" & a).Model.Label = UserFieldDataType(a-1,0) + .GetControl("TextField" & a).Model.Text = UserFieldFamily(CurFieldIndex, a-1) + Next a + .Model.ScrollBar1.ScrollValueMax = (SBMAXFIELDINDEX+1) - SBTBCOUNT + .Model.ScrollBar1.BlockIncrement = SBTBCOUNT + .Model.ScrollBar1.LineIncrement = 1 + .Model.ScrollBar1.ScrollValue = ScrollBarValue + End With +End Sub + + +Sub ScrollControls() + ScrollTextFieldInfo(ScrollBarValue) + ScrollBarValue = DlgUserFields.Model.ScrollBar1.ScrollValue + If (ScrollBarValue + SBTBCOUNT) >= SBMAXFIELDINDEX + 1 Then + ScrollBarValue = (SBMAXFIELDINDEX + 1) - SBTBCOUNT + End If + FillupTextFields() +End Sub + + +Sub ScrollTextFieldInfo(ByVal iScrollValue as Integer) +Dim a as Integer +Dim CurIndex as Integer + For a = 1 To SBTBCOUNT + CurIndex = (a-1) + iScrollValue + UserFieldFamily(CurFieldIndex,CurIndex) = DlgUserFields.GetControl("TextField" & a).Model.Text + Next a +End Sub + + +Sub StopMacro() + DlgUserFields.EndExecute +End Sub + + +Sub SaveSettings() +Dim n as Integer +Dim m as Integer +Dim MaxIndex as Integer + ScrollTextFieldInfo(DlgUserFields.Model.ScrollBar1.ScrollValue) + MaxIndex = Ubound(UserFieldFamily(), 1) + Dim FileStrings(MaxIndex) as String + For n = 0 To MaxIndex + FileStrings(n) = "" + For m = 0 To SBMAXFIELDINDEX + FileStrings(n) = FileStrings(n) & UserFieldFamily(n,m) & ";" + Next m + Next n + SaveDataToFile(FilePath, FileStrings(), True) +End Sub + + +Sub ToggleButtons(ByVal Index as Integer) +Dim i as Integer + CurFieldIndex = Index + DlgUserFields.Model.cmdNextUser.Enabled = CurFieldIndex <> Ubound(UserFieldFamily(), 1) + DlgUserFields.Model.cmdPrevUser.Enabled = CurFieldIndex <> 0 +End Sub + + +Sub InitializeUserFamily() +Dim FirstIndex as Integer +Dim UserFieldstrings() as String +Dim LocStrings() as String +Dim bFileExists as Boolean +Dim n as Integer +Dim m as Integer + bFileExists = LoadDataFromFile(GetPathSettings("Config", False) & "/" & "UserData.dat", UserFieldStrings()) + If bFileExists Then + FirstIndex = Ubound(UserFieldStrings()) + ReDim Preserve UserFieldFamily(FirstIndex, SBMAXFIELDINDEX) as String + For n = 0 To FirstIndex + LocStrings() = ArrayOutofString(UserFieldStrings(n), ";") + For m = 0 To SBMAXFIELDINDEX + UserFieldFamily(n,m) = LocStrings(m) + Next m + Next n + Else + ReDim Preserve UserFieldFamily(0,SBMAXFIELDINDEX) as String + For m = 0 To SBMAXFIELDINDEX + UserFieldFamily(0,m) = oUserDataAccess.GetByName(UserFieldDataType(m,1)) + Next m + End If + ToggleButtons(0) +End Sub + + +Sub AddRecord() +Dim i as Integer +Dim MaxIndex as Integer + For i = 1 To SBTBCount + DlgUserFields.GetControl("TextField" & i).Model.Text = "" + Next i + MaxIndex = Ubound(UserFieldFamily(),1) + ReDim Preserve UserFieldFamily(MaxIndex + 1, SBMAXFIELDINDEX) as String + ToggleButtons(MaxIndex + 1, 1) +End Sub + + +Sub FillupTextFields() +Dim a as Integer +Dim CurIndex as Integer + For a = 1 To SBTBCOUNT + CurIndex = (a-1) + ScrollBarValue + DlgUserFields.GetControl("Label" & a).Model.Label = UserFieldDataType(CurIndex,0) + DlgUserFields.GetControl("TextField" & a).Model.Text = UserFieldFamily(CurFieldIndex, CurIndex) + Next a +End Sub + + +Sub StepToRecord(aEvent as Object) +Dim iStep as Integer + iStep = CInt(aEvent.Source.Model.Tag) + ScrollTextFieldInfo(ScrollBarValue) + ToggleButtons(CurFieldIndex + iStep) + FillUpTextFields() +End Sub + + +Sub SelectCurrentFields() +Dim MaxIndex as Integer +Dim i as Integer + ScrollTextFieldInfo(ScrollBarValue) + MaxIndex = Ubound(UserFieldFamily(),2) + For i = 0 To MaxIndex + oUserDataAccess.ReplaceByName(UserFieldDataType(i,1), UserFieldFamily(CurFieldIndex, i)) + Next i + oUserDataAccess.commitChanges() +End Sub + + +Sub DeleteCurrentSettings() +Dim n as Integer +Dim m as Integer +Dim MaxIndex as Integer + MaxIndex = Ubound(UserFieldFamily(),1) + If CurFieldIndex < MaxIndex Then + For n = CurFieldIndex To MaxIndex - 1 + For m = 0 To SBMAXFIELDINDEX + UserFieldFamily(n,m) = UserFieldFamily(n + 1,m) + Next m + Next n + Else + CurFieldIndex = MaxIndex - 1 + End If + ReDim Preserve UserFieldFamily(MaxIndex-1, SBMAXfIELDINDEX) as String + FillupTextFields() + ToggleButtons(CurFieldIndex) +End Sub \ No newline at end of file diff --git a/wizards/source/gimmicks/dialog.xlb b/wizards/source/gimmicks/dialog.xlb new file mode 100644 index 000000000..22271dacb --- /dev/null +++ b/wizards/source/gimmicks/dialog.xlb @@ -0,0 +1,6 @@ + + + + + + diff --git a/wizards/source/gimmicks/readdirs.dlg b/wizards/source/gimmicks/readdirs.dlg new file mode 100644 index 000000000..20a89426d Binary files /dev/null and b/wizards/source/gimmicks/readdirs.dlg differ diff --git a/wizards/source/gimmicks/script.xlb b/wizards/source/gimmicks/script.xlb new file mode 100644 index 000000000..5c820ba43 --- /dev/null +++ b/wizards/source/gimmicks/script.xlb @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/wizards/source/imagelists/imagelists.ilst b/wizards/source/imagelists/imagelists.ilst new file mode 100644 index 000000000..0a6714c65 --- /dev/null +++ b/wizards/source/imagelists/imagelists.ilst @@ -0,0 +1,7 @@ +%MODULE%/dbaccess/res/exinfo.png +%MODULE%/wizards/res/portrait_32.png +%MODULE%/wizards/res/landscape_32.png +%MODULE%/wizards/res/formarrangelistside_42.png +%MODULE%/wizards/res/formarrangelisttop_42.png +%MODULE%/wizards/res/formarrangetable_42.png +%MODULE%/wizards/res/formarrangefree_42.png diff --git a/wizards/source/importwizard/API.xba b/wizards/source/importwizard/API.xba new file mode 100644 index 000000000..97111aeca --- /dev/null +++ b/wizards/source/importwizard/API.xba @@ -0,0 +1,216 @@ + + + +Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _ + (ByVal hKey As Long, _ + ByVal lpSubKey As String, _ + ByVal ulOptions As Long, _ + ByVal samDesired As Long, _ + phkResult As Long) As Long + +Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _ + (ByVal hKey As Long, _ + ByVal lpValueName As String, _ + ByVal lpReserved As Long, _ + lpType As Long, _ + lpData As String, _ + lpcbData As Long) As Long + +Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" _ + (ByVal hKey As Long, _ + ByVal lpValueName As String, _ + ByVal lpReserved As Long, _ + lpType As Long, _ + lpData As Long, _ + lpcbData As Long) As Long + +Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _ + (ByVal hKey As Long, _ + ByVal lpValueName As String, _ + ByVal lpReserved As Long, _ + lpType As Long, _ + ByVal lpData As Long, _ + lpcbData As Long) As Long + +Declare Function RegCloseKeyA Lib "advapi32.dll" Alias "RegCloseKey" _ + (ByVal hKey As Long) As Long + + +Public Const HKEY_CLASSES_ROOT = &H80000000 +Public Const HKEY_CURRENT_USER = &H80000001 +Public Const HKEY_LOCAL_MACHINE = &H80000002 +Public Const HKEY_USERS = &H80000003 +Public Const KEY_ALL_ACCESS = &H3F +Public Const REG_OPTION_NON_VOLATILE = 0 +Public Const REG_SZ As Long = 1 +Public Const REG_DWORD As Long = 4 +Public Const ERROR_NONE = 0 +Public Const ERROR_BADDB = 1 +Public Const ERROR_BADKEY = 2 +Public Const ERROR_CANTOPEN = 3 +Public Const ERROR_CANTREAD = 4 +Public Const ERROR_CANTWRITE = 5 +Public Const ERROR_OUTOFMEMORY = 6 +Public Const ERROR_INVALID_PARAMETER = 7 +Public Const ERROR_ACCESS_DENIED = 8 +Public Const ERROR_INVALID_PARAMETERS = 87 +Public Const ERROR_NO_MORE_ITEMS = 259 +'Public Const KEY_READ = &H20019 + + +Function OpenRegKey(lBaseKey As Long, sKeyName As String) As Variant +Dim LocKeyValue +Dim hKey as Long +Dim lRetValue as Long + lRetValue = RegOpenKeyEx(lBaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) +' lRetValue = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Outlook Express\5.0\Default Settings", "Revocation Checking") + If hKey <> 0 Then + RegCloseKeyA (hKey) + End If + OpenRegKey() = lRetValue +End Function + + +Function GetDefaultPath(CurOffice as Integer) As String +Dim sPath as String +Dim Index as Integer + Select Case Wizardmode + Case SBMICROSOFTMODE + Index = Applications(CurOffice,SBAPPLKEY) + If GetGUIType = 1 Then ' Windows + sPath = QueryValue(HKEY_LOCAL_MACHINE, sKeyName(Index), sValueName(Index)) + Else + sPath = "" + End If + If sPath = "" Then + sPath = SOWorkPath + End If + GetDefaultPath = sPath + End Select +End Function + + +Function GetTemplateDefaultPath(Index as Integer) As String +Dim sLocTemplatePath as String +Dim sLocProgrampath as String +Dim Progstring as String +Dim PathList()as String +Dim Maxindex as Integer +Dim OldsLocTemplatePath +Dim sTemplateKeyName as String +Dim sTemplateValueName as String + On Local Error Goto NOVAlIDSYSTEMPATH + Select Case WizardMode + Case SBMICROSOFTMODE + If GetGUIType = 1 Then ' Windows + ' Template directory of Office 97 + sTemplateKeyName = "Software\Microsoft\Office\8.0\Common\FileNew\LocalTemplates" + sTemplateValueName = "" + sLocTemplatePath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName) + + If sLocTemplatePath = "" Then + ' Retrieve the template directory of Office 2000 + ' Unfortunately there is no existing note about the template directory in + ' the whole registry. + + ' Programdirectory of Office 2000 + sTemplateKeyName = "Software\Microsoft\Office\9.0\Common\InstallRoot" + sTemplateValueName = "Path" + sLocProgrampath = QueryValue(HKEY_LOCAL_MACHINE, sTemplateKeyName, sTemplateValueName) + If sLocProgrampath <> "" Then + If Right(sLocProgrampath, 1) <> "\" Then + sLocProgrampath = sLocProgrampath & "\" + End If + PathList() = ArrayoutofString(sLocProgrampath,"\",Maxindex) + Progstring = "\" & PathList(Maxindex-1) & "\" + OldsLocTemplatePath = DeleteStr(sLocProgramPath,Progstring) + + sLocTemplatePath = OldsLocTemplatePath & "\" & "Templates" + + ' Does this subdirectory "templates" exist at all + If oUcb.Exists(sLocTemplatePath) Then + ' If Not the main directory of the office is the base + sLocTemplatePath = OldsLocTemplatePath + End If + Else + sLocTemplatePath = SOWorkPath + End If + End If + GetTemplateDefaultPath = ConvertToUrl(sLocTemplatePath) + Else + GetTemplateDefaultPath = SOWorkPath + End If + End Select +NOVALIDSYSTEMPATH: + If Err <> 0 Then + GetTemplateDefaultPath() = SOWorkPath + Resume ONITGOES + ONITGOES: + End If +End Function + + +Function QueryValueEx(ByVal lhKey, ByVal szValueName As String, vValue As String) As Long +Dim cch As Long +Dim lrc As Long +Dim lType As Long +Dim lValue As Long +Dim sValue As String +Dim Empty + + On Error GoTo QueryValueExError + + lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch) + If lrc <> ERROR_NONE Then Error 5 + Select Case lType + Case REG_SZ: + sValue = String(cch, 0) + lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch) + If lrc = ERROR_NONE Then + vValue = Left$(sValue, cch) + Else + vValue = Empty + End If + Case REG_DWORD: + lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch) + If lrc = ERROR_NONE Then + vValue = lValue + End If + Case Else + lrc = -1 + End Select +QueryValueExExit: + QueryValueEx = lrc + Exit Function +QueryValueExError: + Resume QueryValueExExit +End Function + + +Function QueryValue(BaseKey As Long, sKeyName As String, sValueName As String) As Variant +Dim lRetVal As Long ' Returnvalue API-Call +Dim hKey As Long ' One key handle +Dim vValue As String ' Key value + + lRetVal = RegOpenKeyEx(BaseKey, sKeyName, 0, KEY_ALL_ACCESS, hKey) + lRetVal = QueryValueEx(hKey, sValueName, vValue) + RegCloseKeyA (hKey) + QueryValue = vValue +End Function + diff --git a/wizards/source/importwizard/DialogModul.xba b/wizards/source/importwizard/DialogModul.xba new file mode 100644 index 000000000..0bf782c6b --- /dev/null +++ b/wizards/source/importwizard/DialogModul.xba @@ -0,0 +1,484 @@ + + + +Option Explicit + +Public Const bDebugWizard = True + +Public Const SBFIRSTAPPLCHECKED = 0 +Public Const SBSECONDAPPLCHECKED = 1 +Public Const SBTHIRDAPPLCHECKED = 2 +Public Const SBFOURTHAPPLCHECKED = 3 +Public WizardMode as String +Public Const SBMICROSOFTMODE = "MS" +' The absolute maximal Number of possible Applications +Public Const SBMAXAPPLCOUNT = 4 +Public Const Twip = 425 +Public MaxApplCount as Integer +Public CurOffice As Integer +Public SOBitmapPath As String +Public SOWorkPath As String +Public SOTemplatePath as String +Public bCancelTask As Boolean +Public bDoKeepApplValues as Boolean +Public oUcb as Object +Public PathSeparator as String + +Public ApplCount as Integer +Public sKeyName(SBMAXAPPLCOUNT-1) as String +Public sValueName(SBMAXAPPLCOUNT-1) as String +Public sCRLF as String +Public MSFilterName(5,4) as String + +Public Applications(SBMAXAPPLCOUNT-1,9) + +Public Const SBAPPLCONVERT = 0 +Public Const SBDOCCONVERT = 1 +Public Const SBDOCRECURSIVE = 2 +Public Const SBDOCSOURCE = 3 +Public Const SBDOCTARGET = 4 +Public Const SBTEMPLCONVERT = 5 +Public Const SBTEMPLRECURSIVE = 6 +Public Const SBTEMPLSOURCE = 7 +Public Const SBTEMPLTARGET = 8 +Public Const SBAPPLKEY = 9 +Public XMLTemplateList() + +' Application-relating Data are stored in this Array +' according to the following structure: +' Applications(X,0) = True/False (Application is to be converted) +' Applications(X,1) = True/False (Documents are to be converted) +' Applications(X,2) = True/False (Including Subdirectories) +' Applications(X,3) = "File:///..." (SourceUrl of the documents) +' Applications(X,4) = "File///:..." (TargetUrl of the documents) +' Applications(X,5) = True/False (Templates are to be converted) +' Applications(X,6) = True/False (Including Subdirectories) +' Applications(X,7) = "File:///..." (SourceUrl of the templates) +' Applications(X,8) = "File:///..." (TargetUrl of the templates) +' Applications(X,9) = 0 (Key to the original Index of the Applications) + + +Sub FillStep_Welcome() +Dim i as Integer +' bDoKeepApplValues = False + ImportDialogArea.Title = sTitle + With ImportDialog + .cmdHelp.Label = sHelpButton + .cmdCancel.Label = sCancelButton + .cmdBack.Label = sBackButton + .cmdGoOn.Label = sNextButton + .WelcomeTextLabel.Label = sWelcomeTextLabel1 + .WelcomeTextLabel3.Label = sWelcomeTextLabel3 + + .optMSDocuments.Label = sContainerName(0) + .chkMSApplication1.Label = sMsDocumentCheckbox(0) + .chkMSApplication2.Label = sMsDocumentCheckbox(1) + .chkMSApplication3.Label = sMsDocumentCheckbox(2) + + .cmdBack.Enabled = False + .Step = 1 + + If Not oFactoryKey.hasbyName("com.sun.star.text.TextDocument") Then + .chkLogfile.State = 0 + .chkLogfile.Enabled = False + End If + End With + CheckModuleInstallation() + ToggleNextButton() +End Sub + + +Sub FillStep_InputPaths(OfficeIndex as Integer, bStartup as Boolean) +Dim Index as Integer +Dim oNullObject as Object + If bStartup And Not bDoKeepApplValues Then + If ImportDialog.optMSDocuments.State = 1 Then + SetupMSConfiguration() + Else + 'Not supposed to happen - is there an assert in BASIC... + End If + FillUpApplicationList() + End If + CurOffice = OfficeIndex + Index = Applications(CurOffice,SBAPPLKEY) + InitializePathsforCurrentApplication(Index) + With ImportDialog + .chkTemplatePath.Label = sTemplateCheckbox(Index) + .chkDocumentPath.State = Abs(Applications(CurOffice,SBDOCCONVERT)) + .chkDocumentSearchSubDir.State = Abs(Applications(CurOffice,SBDOCRECURSIVE)) + .txtDocumentImportPath.Text = ConvertFromUrl(Applications(CurOffice,SBDOCSOURCE)) + .txtDocumentExportPath.Text = ConvertFromUrl(Applications(CurOffice,SBDOCTARGET)) + .hlnDocuments.Label = sProgressMoreDocs + If WizardMode = SBMICROSOFTMODE Then + ImportDialogArea.Title = sTitle & " - " & sMSDocumentCheckBox(Index) + End If + .chkTemplatePath.Enabled = True + .chkDocumentPath.Enabled = True + .chkTemplatePath.Label = sTemplateCheckbox(Index) + .chkDocumentPath.Label = sDocumentCheckbox(Index) + .hlnTemplates.Label = sProgressMoreTemplates + .chkTemplatePath.State = Abs(Applications(CurOffice,SBTEMPLCONVERT)) + ToggleInputPaths(oNullObject,"Template") + ToggleInputPaths(oNullObject,"Document") + .chkTemplateSearchSubDir.State = Abs(Applications(CurOffice,SBTEMPLRECURSIVE)) + .txtTemplateImportPath.Text = ConvertFromUrl(Applications(CurOffice,SBTEMPLSOURCE)) + .txtTemplateExportPath.Text = ConvertFromUrl(Applications(CurOffice,SBTEMPLTARGET)) + .cmdGoOn.Label = sNextButton + .cmdBack.Enabled = True + ImportDialog.Step = 2 + End With + ImportDialogArea.GetControl("chkTemplatePath").SetFocus() + ToggleNextButton() +End Sub + + +Sub FillUpApplicationList() +Dim i as Integer +Dim a as Integer +Dim BoolValue as Boolean + If Not bDoKeepApplValues Then + a = 0 + For i = 1 To ApplCount + If ImportDialog.optMSDocuments.State = 1 Then + BoolValue = ImportDialogArea.GetControl("chkMSApplication" & i).Model.State = 1 + End If + Applications(a,SBAPPLCONVERT) = BoolValue + Applications(a,SBDOCCONVERT) = BoolValue + Applications(a,SBDOCRECURSIVE) = BoolValue + Applications(a,SBDOCSOURCE) = "" ' GetDefaultPath(i) + Applications(a,SBDOCTARGET) = "" ' SOWorkPath + Applications(a,SBTEMPLCONVERT) = BoolValue + Applications(a,SBTEMPLRECURSIVE) = BoolValue + Applications(a,SBTEMPLSOURCE) = "" ' GetTemplateDefaultPath(i) + Applications(a,SBTEMPLTARGET) = "" ' GetTargetTemplatePath(i) + Applications(a,SBAPPLKEY) = i-1 + If BoolValue Then + a = a + 1 + End If + Next i + ApplCount = a + End If +End Sub + + +Sub InitializePathsforCurrentApplication(i as Integer) + AssignPathToCurrentApplication(SBDOCSOURCE, GetDefaultPath(i)) + AssignPathToCurrentApplication(SBDOCTARGET, SOWorkPath) + AssignPathToCurrentApplication(SBTEMPLSOURCE, GetTemplateDefaultPath(i)) + AssignPathToCurrentApplication(SBTEMPLTARGET, GetTargetTemplatePath(i)) +End Sub + + +Sub AssignPathToCurrentApplication(Index as Integer, NewPath as String) + If Applications(CurOffice,Index) = "" Then + If CurOffice > 0 Then + Applications(CurOffice,Index) = Applications(CurOffice-1,Index) + Else + Applications(CurOffice,Index) = NewPath + End If + End If +End Sub + + +Sub SaveStep_InputPath() + Applications(CurOffice,SBDOCCONVERT) = ImportDialog.chkDocumentPath.State = 1 + Applications(CurOffice,SBDOCRECURSIVE) = ImportDialog.chkDocumentSearchSubDir.State = 1 + Applications(CurOffice,SBDOCSOURCE) = ConvertToURL(ImportDialog.txtDocumentImportPath.Text) + Applications(CurOffice,SBDOCTARGET) = ConvertToUrl(ImportDialog.txtDocumentExportPath.Text) + Applications(CurOffice,SBTEMPLCONVERT) = ImportDialog.chkTemplatePath.State = 1 + Applications(CurOffice,SBTEMPLRECURSIVE) = ImportDialog.chkTemplateSearchSubDir.State = 1 + Applications(CurOffice,SBTEMPLSOURCE) = ConvertToURL(ImportDialog.txtTemplateImportPath.Text) + Applications(CurOffice,SBTEMPLTARGET) = ConvertToURL(ImportDialog.txtTemplateExportPath.Text) +End Sub + + +Sub ToggleInputPaths(aEvent as Object, Optional sDocType) +Dim bDoEnable as Boolean +Dim sLocDocType as String +Dim oCheckBox as Object + If Not IsNull(aEvent) Then + sLocDocType = aEvent.Source.Model.Tag + Else + sLocDocType = sDocType + End If + With ImportDialogArea + oCheckBox = .GetControl("chk" & sLocDocType & "Path").Model + bDoEnable = oCheckBox.State = 1 And oCheckBox.Enabled + .GetControl("lbl" & sLocDocType & "Import").Model.Enabled = bDoEnable + .GetControl("lbl" & sLocDocType & "Export").Model.Enabled = bDoEnable + .GetControl("txt" & sLocDocType & "ImportPath").Model.Enabled = bDoEnable + .GetControl("txt" & sLocDocType & "ExportPath").Model.Enabled = bDoEnable + .GetControl("chk" & sLocDocType & "SearchSubDir").Model.Enabled = bDoEnable + .GetControl("cmd" & sLocDocType & "Import").Model.Enabled = bDoEnable + .GetControl("cmd" & sLocDocType & "Export").Model.Enabled = bDoEnable + End With + ToggleNextButton() +End Sub + + +Function MakeSummaryString() +Dim sTmpText As String +Dim i as Integer +Dim Index as Integer +Dim sAddText as String + For i = 0 To ApplCount -1 + Index = Applications(i,SBAPPLKEY) + If Applications(i,SBTEMPLCONVERT) Then + ' Templates are to be converted + sAddText = "" + If WizardMode = SBMICROSOFTMODE Then + sAddText = sSumMSTemplates(Index) & sCRLF + End If + sTmpText = sTmpText & sAddText & ConvertFromUrl(Applications(i,SBTEMPLSOURCE)) & sCRLF + If Applications(i,SBTEMPLRECURSIVE) Then + ' Including Subdirectories + sTmpText = sTmpText & sSumInclusiveSubDir & sCRLF + End If + sTmpText = sTmpText & sSumSaveDocuments & sCRLF + sTmpText = sTmpText & ConvertFromUrl(Applications(i,SBTEMPLTARGET)) & sCRLF + sTmpText = sTmpText & sCRLF + End If + + If Applications(i,SBDOCCONVERT) Then + ' Documents are to be converted + If WizardMode = SBMICROSOFTMODE Then + sAddText = sSumMSDocuments(Index) & sCRLF + End If + sTmpText = sTmpText & sAddText & ConvertFromUrl(Applications(i,SBDOCSOURCE)) & sCRLF + + If Applications(i,SBDOCRECURSIVE) Then + ' Including Subdirectories + sTmpText = sTmpText & sSumInclusiveSubDir & sCRLF + End If + + sTmpText = sTmpText & sSumSaveDocuments & sCRLF + sTmpText = sTmpText & ConvertFromUrl(Applications(i,SBDOCTARGET)) & sCRLF + sTmpText = sTmpText & sCRLF + End If + Next i + MakeSummaryString = sTmpText +End Function + + +Sub FillStep_Summary() + ImportDialogArea.Title = sTitle + With ImportDialog + .SummaryTextbox.Text = MakeSummaryString() + .cmdGoOn.Enabled = .SummaryTextbox.Text <> "" + .cmdGoOn.Label = sBeginButton + .SummaryHeaderLabel.Label = sSummaryHeader + .Step = 3 + End With + ImportDialogArea.GetControl("SummaryHeaderLabel").SetFocus() +End Sub + + +Sub FillStep_Progress() + With ImportDialog + .cmdBack.Enabled = False + .cmdGoOn.Enabled = False + .hlnProgress.Label = sProgressPage_1 + .LabelRetrieval.FontWeight = com.sun.star.awt.FontWeight.BOLD + .LabelRetrieval.Label = sProgressPage_2 + .LabelCurProgress.Label = sProgressPage_3 + .LabelCurDocumentRetrieval.Label = "" + .LabelCurTemplateRetrieval.Label = "" + .LabelCurDocument.Label = "" + .Step = 4 + End With + ImportDialogArea.GetControl("LabelRetrieval").SetFocus() + If ImportDialog.chkLogfile.State = 1 Then + ImportDialog.cmdShowLogFile.DefaultButton = True + End If +End Sub + + +Sub SetupMSConfiguration() + Wizardmode = SBMICROSOFTMODE + MaxApplCount = 3 + ApplCount = 3 + ' chkTemplatePath-Captions + sTemplateCheckBox(0) = GetResText("MSTemplateCheckbox_1_") + sTemplateCheckBox(1) = GetResText("MSTemplateCheckbox_2_") + sTemplateCheckBox(2) = GetResText("MSTemplateCheckbox_3_") + ' DocumentCheckbox- Captions + sDocumentCheckBox(0) = GetResText("MSDocumentCheckbox_1_") + sDocumentCheckBox(1) = GetResText("MSDocumentCheckbox_2_") + sDocumentCheckBox(2) = GetResText("MSDocumentCheckbox_3_") + + sKeyName(0) = "Software\Microsoft\Office\8.0\Word\Options" + sKeyName(1) = "Software\Microsoft\Office\8.0\Excel\Microsoft Excel" + sKeyName(2) = "Software\Microsoft\Office\8.0\PowerPoint\Recent Folder List\Default" + + sValueName(0) = "DOC-PATH" + sValueName(1) = "DefaultPath" + sValueName(2) = "" + +' See definition of Filtername-Array about meaning of fields + MSFilterName(0,0) = "doc|docx|docm" + MSFilterName(0,1) = "writer8|writer8|writer8" + MSFilterName(0,2) = "odt|odt|odt" + MSFilterName(0,3) = sMSDocumentCheckBox(0) + MSFilterName(0,4) = "Word" + + + MSFilterName(1,0) = "xls|xlsx|xlsm" + MSFilterName(1,1) = "calc8|calc8|calc8" + MSFilterName(1,2) = "ods|ods|ods" + MSFilterName(1,3) = sMSDocumentCheckBox(1) + MSFilterName(1,4) = "Excel" + + MSFilterName(2,0) = "ppt|pps|pptx|pub|pptm|ppsx|ppsm" + MSFilterName(2,1) = "impress8|impress8|impress8|impress8|impress8|impress8|impress8" + MSFilterName(2,2) = "odp|odp|odp|odp|odp|odp|odp" + MSFilterName(2,3) = sMSDocumentCheckBox(2) + MSFilterName(2,4) = "PowerPoint/Publisher" + + MSFilterName(3,0) = "dot|dotx|dotm" + MSFilterName(3,1) = "writer8_template|writer8_template|writer8_template" + MSFilterName(3,2) = "ott|ott|ott" + MSFilterName(3,3) = sMSTemplateCheckBox(0) + MSFilterName(3,4) = "Word" + + MSFilterName(4,0) = "xlt|xltx|xltm" + MSFilterName(4,1) = "calc8_template|calc8_template|calc8_template" + MSFilterName(4,2) = "ots|ots|ots" + MSFilterName(4,3) = sMSTemplateCheckBox(1) + MSFilterName(4,4) = "Excel" + + MSFilterName(5,0) = "pot|potx|potm" + MSFilterName(5,1) = "impress8_template|impress8_template|impress8_template" + MSFilterName(5,2) = "otp|otp|otp" + MSFilterName(5,3) = sMSTemplateCheckBox(2) + MSFilterName(5,4) = "PowerPoint" +End Sub + + +Function CheckControlPath(oCheckbox as Object, oTextBox as Object, ByVal bDoEnable as Boolean) +Dim sPath as String + If Not bDoEnable Then + CheckControlPath = False + ElseIf oCheckbox.State = 0 Then + CheckControlPath = True + Else + sPath = ConvertToUrl(Trim(oTextBox.Text)) + CheckControlPath = oUcb.Exists(sPath) + End If +End Function + + +Function CheckInputPaths() as Boolean +Dim bChangePage as Boolean + bChangePage = CheckTextBoxPath(ImportDialog.txtTemplateImportPath, True, False, sTitle, False) + bChangePage = CheckTextBoxPath(ImportDialog.txtTemplateExportPath, bChangePage, True, sTitle, False) + bChangePage = CheckTextBoxPath(ImportDialog.txtDocumentImportPath, bChangePage, False, sTitle, False) + bChangePage = CheckTextBoxPath(ImportDialog.txtDocumentExportPath, bChangePage, True, sTitle, False) + CheckInputPaths = bChangePage +End Function + + +Function CheckTextBoxPath(oTextBox as Object, ByVal bCheck as Boolean, bCreateNew as Boolean, sTitle as String, bgetResources as Boolean) as Boolean +Dim iCreate as Integer +Dim sQueryMessage as String +Dim sUrlPath as String +Dim sMessageNoDir as String +Dim sShowPath as String +Dim oLocUcb as Object + oLocUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + If bGetResources Then + If InitResources("ImportWizard") then + sNoDirCreation = GetResText("NoDirCreation") + sMsgDirNotThere = GetResText("MsgDirNotThere") + sQueryForNewCreation = GetResText("QueryfornewCreation") + Else + CheckTextBoxPath() = False + Exit Function + End If + End If + If oTextBox.Enabled Then + If bCheck Then + sShowPath = oTextBox.Text + sUrlPath = ConvertToUrl(sShowPath) + If Not oLocUcb.Exists(sUrlPath) Then + If Not bCreateNew Then + ' Sourcedirectories must be existing, Targetdirectories may be created new + sQueryMessage = ReplaceString(sMsgDirNotThere, sShowPath,"%1") + Msgbox(sQueryMessage,16,sTitle) + CheckTextBoxPath() = False + Exit Function + Else + sQueryMessage = ReplaceString(sMsgDirNotThere, sShowPath,"%1") + sQueryMessage = sQueryMessage & Chr(13) & sQueryForNewCreation + iCreate = Msgbox (sQueryMessage, 36, sTitle) + If iCreate = 6 Then + On Local Error Goto NOVALIDPATH + CreateFolder(sUrlPath) + If Not oLocUcb.Exists(sUrlPath) Then + Goto NOVALIDPATH + End If + Else + CheckTextBoxPath() = False + Exit Function + End If + End If + End If + CheckTextBoxPath() = True + Else + CheckTextBoxPath() = False + End If + Else + CheckTextBoxPath() = True + End If + Exit Function +NOVALIDPATH: + sMessageNoDir = ReplaceString(sNoDirCreation, sShowPath, "%1") + Msgbox(sMessageNoDir, 16, sTitle) + CheckTextBoxPath() = False +End Function + + +Sub InitializeProgressPage(oDialog as Object) + oDialog.LabelRetrieval.FontWeight = com.sun.star.awt.FontWeight.NORMAL + oDialog.LabelCurProgress.FontWeight = com.sun.star.awt.FontWeight.BOLD +End Sub + + +Sub SetProgressDisplay(AbsFound as Integer) + ImportDialog.LabelRetrieval.Label = sProgressPage_2 & " " & ReplaceString(sProgressPage_5, Str(AbsFound) & " ", "%1") + ImportDialog.LabelCurDocumentRetrieval.Label = sProgressFound & " " & CStr(AbsDocuFound) & " " & sProgressMoreDocs + ImportDialog.LabelCurTemplateRetrieval.Label = sProgressFound & " " & CStr(AbsTemplateFound) & " " & sProgressMoreTemplates +End Sub + +Sub TakoverFolderName(aEvent as Object) +Dim RefControlName as String +Dim oRefControl + RefControlName = aEvent.Source.Model.Tag + oRefControl = ImportDialogArea.GetControl(RefControlName) + GetFolderName(oRefControl.Model) + ToggleNextButton() +End Sub + + +Sub FinalizeDialogButtons() + ImportDialog.cmdShowLogFile.Enabled = ((Isnull(oLogDocument) = False) And (ImportDialog.chkLogfile.State = 1)) + ImportDialog.cmdCancel.Enabled = False + ImportDialog.cmdGoOn.Label = sCloseButton + ImportDialog.cmdGoOn.Enabled = True +End Sub + diff --git a/wizards/source/importwizard/FilesModul.xba b/wizards/source/importwizard/FilesModul.xba new file mode 100644 index 000000000..cfac77dfe --- /dev/null +++ b/wizards/source/importwizard/FilesModul.xba @@ -0,0 +1,783 @@ + + + +Option Explicit + +Public AbsTemplateFound as Integer +Public AbsDocuFound as Integer +Public oLogDocument as Object +Public oLogTable as Object +Public bLogExists as Boolean +Public sComment as String +Public MaxCollectIndex as Integer +Public bInsertRow as Boolean +Public sLogUrl as String +Public sCurPassWord as String +Public FileCount as Integer +Public XMLTemplateCount as Integer +Public PathCollection(7,3) as String +Public bIsFirstLogTable as Boolean + + +Function ReadCollectionPaths(FilesList() as String, sFilterName() as String) +Dim FilterIndex as Integer +Dim bRecursive as Boolean +Dim SearchDir as String +Dim i as Integer +Dim n as Integer +Dim a as Integer +Dim s as Integer +Dim t as Integer +Dim sFileContent() as String +Dim NewList(0,1) as String +Dim Index as Integer +Dim CurFileName as String +Dim CurExtension as String +Dim CurFileContent as String +Dim XMLTemplateContentList() as String +Dim bIsTemplatePath as Boolean +Dim MaxIndex as Integer +Dim NewContentList() as String +Dim XMLTemplateContentString as String +Dim ApplIndex as Integer +Dim bAssignFileName as Boolean +Dim bInterruptSearch as Boolean + bInterruptSearch = False + For i = 0 To MaxCollectIndex + SearchDir = PathCollection(i,0) + bRecursive = PathCollection(i,1) + sFileContent() = ArrayoutofString(PathCollection(i,2), "|") + NewList() = ReadDirectories(SearchDir, bRecursive, False, False, sFileContent(), "") + If InterruptProcess Then + ReadCollectionPaths() = False + Exit Function + End If + If Ubound(NewList()) > -1 Then + bIsTemplatePath = FieldInList("vor", sFileContent) + If bIsTemplatePath Then + XMLTemplateContentString = PathCollection(i,3) + XMLTemplateContentList() = ArrayoutofString(XMLTemplateContentString, "|") + If Ubound(XMLTemplateContentList()) > -1 Then + MaxIndex = Ubound(NewList()) + ReDim Preserve NewList(MaxIndex, 1) as String + ReDim Preserve NewContentList(MaxIndex) as String + a = -1 + For n = 0 To MaxIndex + bAssignFileName = True + If InterruptProcess() Then + ReadCollectionPaths() = False + Exit Function + End If + CurFileContent = "" + CurFileName = NewList(n,0) + If (FieldInList(NewList(n,1), XMLTemplateList())) Then + CurFileContent = GetRealFileContent(CurFileName) + t = SearchArrayforPartString(CurFileContent, XMLTemplateContentList()) + bAssignFileName = (t > -1) + If bAssignFileName Then + CurFileContent = XMLTemplateContentList(t) + End If + NewList(n,1) = CurFileContent + End If + CurExtension = NewList(n,1) + If bAssignFileName Then + If a < n Then + a = a + 1 + NewList(a,0) = CurFileName + NewList(a,1) = CurExtension + If CurFileContent = "" Then + CurFileContent = CurExtension + End If + ApplIndex = GetApplicationIndex(CurFileContent, sFiltername()) + NewContentList(a) = ApplIndex + End If + End If + Next n + If a < MaxIndex And a > -1 Then + ReDim Preserve NewList(a, 1) as String + End If + If a > -1 Then + AddListtoFilesList(FilesList(), NewList(), NewContentList()) + End If + End If + Else + MaxIndex = Ubound(NewList()) + ReDim Preserve NewContentList(MaxIndex) as String + For s = 0 To MaxIndex + CurExtension = NewList(s,1) + NewContentList(s) = GetApplicationIndex(CurExtension, sFiltername()) + Next s + AddListtoFilesList(FilesList(), NewList(), NewContentList()) + End If + End If + Next i + ReadCollectionPaths() = Ubound(FilesList()) > -1 +End Function + + +Function GetApplicationIndex(CurFileContent as String, sFilterName() as String) as Integer +Dim Index as Integer +Dim i as Integer + Index = GetIndexForPartStringinMultiArray(sFilterName(), CurFileContent, 0) + If Index >= MaxApplCount Then + Index = Index - MaxApplCount + End If + For i = 0 To MaxApplCount - 1 + If Applications(i, SBAPPLKEY) = Index Then + GetApplicationIndex() = i + Exit Function + End If + Next i + GetApplicationIndex() = - 1 +End Function + + +Function InterruptProcess() as Boolean + If bCancelTask Or RetValue = 0 Then + bConversionIsRunning = False + InterruptProcess() = True + Exit Function + End if + InterruptProcess() = False +End Function + + +Sub AddCollectionPath(ApplIndex as Integer, DocIndex as Integer, RecursiveIndex as Integer, sFiltername() as String, DistIndex as Integer) + MaxCollectIndex = MaxCollectIndex + 1 + PathCollection(MaxCollectIndex, 0) = Applications(ApplIndex, DocIndex) + PathCollection(MaxCollectIndex, 1) = Applications(ApplIndex, RecursiveIndex) + AddFilterNameToPathItem(ApplIndex, MaxCollectIndex, sFiltername(), DistIndex) +End Sub + + +Function SetExtension(LocExtension) as String + if (Instr(LocExtension, "vnd.sun.xml.impress")) > 0 then + SetExtension() = "vor|sti|std" + elseif (Instr(LocExtension, "vnd.sun.xml.writer")) > 0 then + SetExtension() = "vor|stw" + elseif (Instr(LocExtension, "vnd.sun.xml.calc")) > 0 then + SetExtension() = "vor|stc" + elseif (Instr(LocExtension, "vnd.sun.xml.draw")) > 0 then + SetExtension() = "vor|std|sti" + endif +End Function + +Sub AddFilterNameToPathItem(ApplIndex as Integer, CollectIndex as Integer, sFiltername() as String, DistIndex as Integer) +Dim iKey as Integer +Dim CurListString as String +Dim LocExtension as String +Dim LocContentString as String +Dim LocXMLTemplateContent as String + iKey = Applications(ApplIndex, SBAPPLKEY) + CurListString = PathCollection(CollectIndex, 2) + LocExtension = sFilterName(iKey +DistIndex, 0) + If Instr(LocExtension, "vnd.sun.xml.") = 1 Then + LocExtension = SetExtension(LocExtension) + LocContentString = sFilterName(iKey +DistIndex, 0) + LocContentString = ReplaceString(LocContentString, "|", ";") + LocXMLTemplateContent = PathCollection(CollectIndex, 3) + If LocXMLTemplateContent = "" Then + LocXMLTemplateContent = LocContentString + Else + LocXMLTemplateContent = LocXMLTemplateContent & "|" & LocContentString + End If + PathCollection(CollectIndex, 3) = LocXMLTemplateContent + End If + If CurListString = "" Then + PathCollection(CollectIndex, 2) = LocExtension + Else + If Instr(CurListString, LocExtension) = 0 Then + PathCollection(CollectIndex, 2) = CurListString & "|" & LocExtension + End If + End If +End Sub + + +Sub CheckIfToAddPathToCollection(ApplIndex as Integer, bDoConvertIndex as Integer, DocIndex as Integer, RecursiveIndex as Integer, sFiltername() as String, DistIndex as Integer) +Dim CollectIndex as Integer +Dim bCheckDocuType as Boolean + bCheckDocuType = Applications(ApplIndex, bDoConvertIndex) + If bCheckDocuType Then + CollectIndex = GetIndexInMultiArray(PathCollection(), Applications(ApplIndex,DocIndex), 0) + If (CollectIndex >-1) Then + If Applications(ApplIndex, RecursiveIndex) <> PathCollection(CollectIndex, 1) Then + AddCollectionPath(ApplIndex, DocIndex, RecursiveIndex, sFilterName(), DistIndex) + Else + AddFilterNameToPathItem(ApplIndex, CollectIndex, sFilterName(), DistIndex) + End If + Else + AddCollectionPath(ApplIndex, DocIndex, RecursiveIndex, sFilterName(), DistIndex) + End If + End If +End Sub + + +Sub CollectPaths(sFiltername() as String) +Dim i as Integer +Dim XMLTemplateContentString as String + MaxCollectIndex = -1 + For i = 0 To ApplCount-1 + CheckIfToAddPathToCollection(i, SBDOCCONVERT, SBDOCSOURCE, SBDOCRECURSIVE, sFilterName(), 0) + Next i + XMLTemplateCount = 0 + XMLTemplateContentString = "" + For i = 0 To ApplCount-1 + CheckIfToAddPathToCollection(i, SBTEMPLCONVERT, SBTEMPLSOURCE, SBTEMPLRECURSIVE, sFilterName(), MaxApplCount) + Next i +End Sub + + +Sub ConvertAllDocuments(sFilterName() as String) +Dim FileProperties(1) as new com.sun.star.beans.PropertyValue +Dim PWFileProperties(2) as New com.sun.star.beans.PropertyValue +Dim WriterWebProperties(0) as new com.sun.star.beans.PropertyValue +Dim OpenProperties(4) as new com.sun.star.beans.PropertyValue +Dim oInteractionHandler as Object +Dim InteractionTypes(0) as Long +Dim FilesList(0,2) as String +Dim sViewPath as String +Dim i as Integer +Dim FilterIndex as Integer +Dim sSourceUrl as String +Dim CurFilename as String +Dim oDocument as Object +Dim sExtension as String +Dim OldExtension as String +Dim CurFound as Integer +Dim TotFound as Integer +Dim TargetStemDir as String +Dim SourceStemDir as String +Dim TargetDir as String +Dim sTargetUrl as String +Dim CurFilterName as String +Dim ApplIndex as Integer +Dim Index as Integer +Dim bIsDocument as Boolean +Dim bDoSave as Boolean +Dim sCurFileExists as String +Dim MaxFileIndex as Integer +Dim bContainsBasicMacro as Boolean +Dim bIsPassWordProtected as Boolean +Dim iOverwrite as Integer +Dim sMimeTypeorExtension as String +Dim sPrevMimeTypeorExtension as String + bConversionisrunning = True + InteractionTypes(0) = com.sun.star.task.PasswordRequestMode.PASSWORD_REENTER + oInteractionHandler = createUnoService("com.sun.star.task.InteractionHandler") + oInteractionHandler.initialize(InteractionTypes()) + iGeneralOverwrite = SBOVERWRITEUNDEFINED + bConversionIsRunning = True + bLogExists = false + AbsTemplateFound = 0 + AbsDocuFound = 0 + CollectPaths(sFiltername()) + If Not ReadCollectionPaths(FilesList(), sFilterName()) Then + TotFound = 0 + SetProgressDisplay(0) + bConversionisrunning = false + FinalizeDialogButtons() + Exit Sub + End If + TotFound = Ubound(FilesList()) + 1 + If FilesList(0,0) = "" Then ' Querying the number of fields in a multidimensional Array is unsecure + TotFound = 0 ' because it will return the value 0 (and not -1) even when the Array is empty + SetProgressDisplay(0) + End If + BubbleSortList(FilesList(), true) + If TotFound > 0 Then + CreateLogDocument(OpenProperties()) + InitializeProgressPage(ImportDialog) + OpenProperties(0).Name = "Hidden" + OpenProperties(0).Value = True + OpenProperties(1).Name = "AsTemplate" + OpenProperties(1).Value = False + OpenProperties(2).Name = "MacroExecutionMode" + OpenProperties(2).Value = com.sun.star.document.MacroExecMode.NEVER_EXECUTE + OpenProperties(3).Name = "UpdateDocMode" + OpenProperties(3).Value = com.sun.star.document.UpdateDocMode.NO_UPDATE + OpenProperties(4).Name = "InteractionHandler" + OpenProperties(4).Value = oInteractionHandler + MaxFileIndex = Ubound(FilesList(),1) + FileCount = 0 + For i = 0 To MaxFileIndex + sComment = "" + If InterruptProcess() Then + Exit For + End If + bDoSave = True + sSourceUrl = FilesList(i,0) + sPrevMimeTypeorExtension = sMimeTypeorExtension + sMimeTypeorExtension = FilesList(i,1) + CurFiltername = GetFilterName(sMimeTypeorExtension, sFilterName(), sExtension, FilterIndex) + ApplIndex = FilesList(i,2) + If sMimeTypeorExtension <> sPrevMimeTypeorExtension Then + CreateLogTable(ApplIndex, sMimeTypeOrExtension, sFiltername()) + End If + If ApplIndex > Ubound(Applications) or (ApplIndex < 0) Then + Msgbox "Applicationindex out of bounds:" & sSourcUrl + End If + sViewPath = ConvertFromUrl(sSourceUrl) ' CutPathView(sSourceUrl, 70) + ImportDialog.LabelCurDocument.Label = Str(i+1) & "/" & MaxFileIndex + 1 & " (" & sViewPath & ")" + Select Case lcase(sExtension) + Case "odt", "ods", "odp", "odg", "odm", "odf" + SourceStemDir = RTrimStr(Applications(ApplIndex,SBDOCSOURCE), "/") + TargetStemDir = RTrimStr(Applications(ApplIndex,SBDOCTARGET), "/") + Case Else ' Templates and Helper-Applications remain + SourceStemDir = RTrimStr(Applications(ApplIndex,SBTEMPLSOURCE), "/") + TargetStemDir = RTrimStr(Applications(ApplIndex,SBTEMPLTARGET), "/") + End Select + sTargetUrl = ReplaceString(sSourceUrl, TargetStemDir, SourceStemDir) + CurFilename = GetFileNameWithoutExtension(sTargetUrl, "/") + OldExtension = GetFileNameExtension(sTargetUrl) + sTargetUrl = RTrimStr(sTargetUrl, OldExtension) + sTargetUrl = sTargetUrl & sExtension + TargetDir = RTrimStr(sTargetUrl, CurFilename & "." & sExtension) + If (oUcb.Exists(sTargetUrl)) Then + If (iGeneralOverwrite <> SBOVERWRITEALWAYS) Then + If (iGeneralOverwrite = SBOVERWRITEUNDEFINED) Then + ShowOverwriteAllDialog(sTargetUrl, sTitle) + bDoSave = (iGeneralOverwrite = SBOVERWRITEQUERY) Or (iGeneralOverwrite = SBOVERWRITEALWAYS) + Elseif iGeneralOverwrite = SBOVERWRITENEVER Then + bDoSave = False + ElseIf ((iGeneralOverWrite = SBOVERWRITEQUERY) OR (iGeneralOverwrite = SBOVERWRITECANCEL)) Then + ' Todo: According to AS there might come a new feature that storeasUrl could possibly rise a UI dialog. + ' In this case my own UI becomes obsolete + sCurFileExists = ReplaceString(sFileExists, ConvertFromUrl(sTargetUrl), "<1>") + sCurFileExists = ReplaceString(sCurFileExists, chr(13), "<CR>") + iOverWrite = Msgbox (sCurFileExists, 32 + 3, sTitle) + Select Case iOverWrite + Case 1 ' OK + ' In the FileProperty-Bean this is already default + bDoSave = True + Case 2 ' Abort + CancelTask(False) + bDoSave = False + Case 7 ' No + bDoSave = False + End Select + End If + End If + End If + If bDoSave Then + If Not oUcb.Exists(TargetDir) Then + bDoSave = CreateFolder(TargetDir) + End If + If bDoSave Then + oDocument = StarDesktop.LoadComponentFromURL(sSourceUrl, "_default", 0, OpenProperties()) + If Not IsNull(oDocument) Then + InsertSourceUrlToLogDocument(sSourceUrl, "") + bIsPassWordProtected = CheckPassWordProtection(oDocument) + CheckIfMacroExists(oDocument.BasicLibraries, sComment) + On Local Error Goto NOSAVING + If bIsPassWordProtected Then + PWFileProperties(0).Name = "FilterName" + PWFileProperties(0).Value = CurFilterName + PWFileProperties(1).Name = "Overwrite" + PWFileProperties(1).Value = True + PWFileProperties(2).Name = "Password" + PWFileProperties(2).Value = sCurPassWord + oDocument.StoreAsUrl(sTargetUrl, PWFileProperties()) + Else + FileProperties(0).Name = "FilterName" + FileProperties(0).Value = CurFilterName + FileProperties(1).Name = "Overwrite" + FileProperties(1).Value = True + oDocument.StoreAsUrl(sTargetUrl,FileProperties()) + End If + ' Todo: Make sure that an errorbox pops up when saving fails + NOSAVING: + If Err <> 0 Then + sCurcouldnotsaveDocument = ReplaceString(scouldnotsaveDocument, ConvertFromUrl(sTargetUrl), "<1>") + sComment = ConcatComment(sComment, sCurCouldnotsaveDocument) + Resume LETSGO + LETSGO: + Else + FileCount = FileCount + 1 + End If + oDocument.Dispose() + InsertTargetUrlToLogDocument(sTargetUrl, sComment) + Else + sCurcouldnotopenDocument = ReplaceString(scouldnotopenDocument, ConvertFromUrl(sSourceUrl), "<1>") + sComment = ConcatComment(sComment, sCurCouldnotopenDocument) + InsertSourceUrlToLogDocument(sSourceUrl, sComment) + End If + End If + End If + Next i + End If + AddLogStatistics() + FinalizeDialogButtons() + bConversionIsRunning = False + Exit Sub +RTError: + Msgbox sRTErrorDesc, 16, sRTErrorHeader +End Sub + + + +Sub AddListtoFilesList(FirstList(), SecList(), NewContentList() as String) +Dim sLocExtension as String +Dim FirstStart as Integer +Dim FirstEnd as Integer +Dim i as Integer +Dim s as Integer + If FirstList(0,0) = "" Then + FirstStart = Ubound(FirstList(),1) + Else + FirstStart = Ubound(FirstList(),1) + 1 + End If + FirstEnd = FirstStart + Ubound(SecList(),1) + ReDim Preserve FirstList(FirstEnd,2) + s = 0 + For i = FirstStart To FirstEnd + FirstList(i,0) = SecList(s,0) + FirstList(i,1) = SecList(s,1) + sLocExtension = lcase(FirstList(i,1)) + Select Case sLocExtension + Case "sdw", "sdc", "sda", "sdd", "smf", "sgl", "doc", "docx", "docm", "xls", "xlsx", "xlsm", "ppt", "pps", "pptx", "pptm", "ppsx", "ppsm", "pub", "sxi", "sxw", "sxd", "sxg", "sxm", "sxc" + AbsDocuFound = AbsDocuFound + 1 + Case else + AbsTemplateFound = AbsTemplateFound + 1 + End Select + FirstList(i,2) = CStr(NewContentList(s)) + s = s + 1 + Next i + SetProgressDisplay(Ubound(FirstList()) + 1) +End Sub + + + +Function GetTargetTemplatePath(Index as Integer) + Select Case WizardMode + Case SBMICROSOFTMODE + GetTargetTemplatePath() = SOTemplatePath & "/" & sTemplateGroupName + End Select +End Function + + +' Retrieves the second value for a next to 'SearchString' in +' a two-dimensional string-Array +Function GetFilterName(sMimetypeorExtension as String, sFilterName(), sExtension as string, FilterIndex as Integer) as String +Dim i as Integer +Dim MaxIndex as Integer +Dim sLocFilterlist() as String + For i = 0 To Ubound(sFiltername(),1) + If Instr(1,sFilterName(i,0),sMimeTypeOrExtension) <> 0 Then + sLocFilterList() = ArrayoutofString(sFiltername(i,0),"|", MaxIndex) + If MaxIndex = 0 Then + sExtension = sFiltername(i,2) + GetFilterName = sFilterName(i,1) + Else + Dim b as Integer + Dim sLocExtensionList() as String + b = SearchArrayForPartString(sMimetypeOrExtension, sLocFilterList()) + sLocFilterList() = ArrayoutofString(sFiltername(i,1),"|", MaxIndex) + GetFilterName = sLocFilterList(b) + sLocExtensionList() = ArrayoutofString(sFilterName(i,2), "|", MaxIndex) + sExtension = sLocExtensionList(b) + End If + Exit For + End If + Next + FilterIndex = i +End Function + + +Function SearchArrayforPartString(SearchString as String, LocList()) as Integer +Dim i as Integer +Dim a as Integer +Dim StringList() as String + For i = Lbound(LocList(),1) to Ubound(LocList(),1) + StringList() = ArrayoutofString(LocList(i), "|") + For a = 0 To Ubound(StringList()) + If (Instr(1, SearchString, StringList(a)) <> 0) Then + SearchArrayForPartString() = i + Exit Function + End If + Next a + Next i + SearchArrayForPartString() = -1 +End Function + + +Sub CreateLogTable(ApplIndex as Integer, CurFileContent as String, sFilterName() as String) +Dim oLogCursor as Object +Dim oLogRows as Object +Dim FilterIndex as Integer +Dim sDocumentType as String +Dim oTextCursor +Dim oCell + If Not bLogExists Then + Exit Sub + End If + FilterIndex = GetIndexForPartStringinMultiArray(sFilterName(), CurFileContent, 0) + sDocumentType = sFiltername(FilterIndex,3) + oLogCursor = oLogDocument.Text.createTextCursor() + oLogCursor.GotoEnd(False) + If Not bIsFirstLogTable Then + oLogDocument.Text.insertControlCharacter(oLogCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False) + Else + bisFirstLogTable = False + End If + oLogCursor.HyperLinkURL = "" + oLogCursor.HyperLinkName = "" + oLogCursor.HyperLinkTarget = "" + oLogCursor.ParaStyleName = "Heading 1" + oLogCursor.setString(sDocumentType) + oLogCursor.CollapsetoEnd() + oLogDocument.Text.insertControlCharacter(oLogCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False) + oLogTable = oLogDocument.CreateInstance("com.sun.star.text.TextTable") + oLogTable.RepeatHeadline = true + oLogCursor.Text.InsertTextContent(oLogCursor, oLogTable, True) + oTextCursor = oLogTable.GetCellbyPosition(0,0).createTextCursor() + oTextCursor.SetString(sSourceDocuments) + oTextCursor = oLogTable.GetCellbyPosition(1,0).createTextCursor() + oTextCursor.SetString(sTargetDocuments) + bInsertRow = False +End Sub + + +Function GetSize(iWidth, iHeight) As New com.sun.star.awt.Size +Dim aSize As New com.sun.star.awt.Size + aSize.Width = iWidth + aSize.Height = iHeight + GetSize() = aSize +End Function + + +Sub InsertCommandButtonatViewCursor(oLocDocument, oLocCursor, TargetUrl as String, Optional aSize) +Dim oDocument +Dim oController +Dim oCommandButton +Dim oShape +Dim oDrawPage +Dim oCommandControl +Dim oEvent +Dim oCell + oCommandButton = oLocDocument.createInstance("com.sun.star.form.component.CommandButton") + oShape = oLocDocument.CreateInstance ("com.sun.star.drawing.ControlShape") + If IsMissing(aSize) Then + oShape.Size = GetSize(4000, 600) + End If + oCommandButton.Label = FileNameoutofPath(Targeturl) + oCommandButton.TargetFrame = "_default" + oCommandButton.ButtonType = com.sun.star.form.FormButtonType.URL + oCommandbutton.DispatchUrlInternal = True + oCommandButton.TargetURL = ConverttoUrl(TargetUrl) + oShape.Control = oCommandbutton + oLocCursor.Text.InsertTextContent(oLocCursor, oShape, True) +End Sub + + + +Sub CreateLogDocument(HiddenProperties()) +Dim OpenProperties(0) as new com.sun.star.beans.PropertyValue +Dim NoArgs() +Dim i as Integer +Dim bLogIsThere as Boolean + If ImportDialog.chkLogfile.State = 1 Then + i = 2 + OpenProperties(0).Name = "Hidden" + OpenProperties(0).Value = True + oLogDocument = StarDesktop.LoadComponentFromURL("private:factory/swriter", "_default", 4, OpenProperties()) + SOWorkPath = RTrimStr(SOWorkPath,"/") + sLogUrl = SOWorkPath & "/Logfile.odt" + Do + bLogIsThere = oUcb.Exists(sLogUrl) + If bLogIsThere Then + If i = 2 Then + sLogUrl = ReplaceString(sLogUrl, "/Logfile_2.odt", "/Logfile.odt") + Else + sLogUrl = ReplaceString(sLogUrl, "/Logfile_" & cStr(i) & ".odt", "/Logfile_" & cStr(i-1) & ".odt") + End If + i = i + 1 + End If + Loop Until Not bLogIsThere + bLogExists = True + oLogDocument.StoreAsUrl(sLogUrl, NoArgs()) + End If +End Sub + + +Sub InsertTargetUrlToLogDocument(sTargetUrl as String, sComment as String) +Dim oCell +Dim oTextCursor +Dim CurFilterTracingpath as String + If (bLogExists) And (sTargetUrl <> "") Then + If sTargetUrl <> "" Then + oCell = oLogTable.GetCellbyPosition(1,oLogTable.Rows.Count-1) + InsertCommentToLogCell(sComment, oCell) + InsertHyperLinkToLogCell(sTargetUrl, oCell) + oLogDocument.Store() + End If + End If +End Sub + + +Sub InsertSourceUrlToLogDocument(SourceUrl as String, sComment) ' +Dim oCell as Object + If bLogExists Then + If bInsertRow Then + oLogTable.Rows.InsertByIndex(oLogTable.Rows.Count,1) + Else + bInsertRow = True + End If + oCell = oLogTable.GetCellbyPosition(0,oLogTable.Rows.Count-1) + InsertCommentToLogCell(sComment, oCell) + InsertHyperLinkToLogCell(SourceUrl, oCell) + oLogDocument.Store() + End If +End Sub + + +Sub InsertHyperLinkToLogCell(sUrl as String, oCell as Object) +Dim oLogCursor as Object +Dim LocFileName as String + oLogCursor = oCell.createTextCursor() + oLogCursor.CollapseToStart() + oLogCursor.HyperLinkURL = sUrl + oLogCursor.HyperLinkName = sUrl + oLogCursor.HyperLinkTarget = sUrl + LocFileName = FileNameOutOfPath(sUrl) + oCell.InsertString(oLogCursor, LocFileName,False) +End Sub + + +Sub InsertCommentToLogCell(sComment as string, oCell as Object) +Dim oCommentCursor as Object + If sComment <> "" Then + oCommentCursor = oCell.createTextCursor() + oCell.insertControlCharacter(oCommentCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False) + oCell.insertString(oCommentCursor, sComment, false) + End If +End Sub + + +Sub AddLogStatistics() +Dim oCell as Object +Dim oLogCursor as Object +Dim MaxRowIndex as Integer + If bLogExists Then + MaxRowIndex = oLogTable.Rows.Count + sLogSummary = ReplaceString(sLogSummary, FileCount, "<COUNT>") +' oLogTable.Rows.InsertByIndex(MaxRowIndex, 1) +' oCell = oLogTable.GetCellbyPosition(0, MaxRowIndex) +' oLogCursor = oCell.createTextCursor() +' oCell.InsertString(oLogCursor, sLogSummary,False) +' MergeRange(oLogTable, oCell, 1) + + oLogCursor = oLogDocument.Text.CreateTextCursor + oLogCursor.gotoEnd(False) + oLogCursor.HyperLinkURL = "" + oLogCursor.HyperLinkName = "" + oLogCursor.HyperLinkTarget = "" + oLogCursor.SetString(sLogSummary) + oLogDocument.Store() + oLogDocument.Dispose() + bLogExists = False + End If +End Sub + + + +Function CheckIfMacroExists(oBasicLibraries as Object, sComment as String) as Boolean +Dim ModuleNames() as String +Dim ModuleName as String +Dim MaxLibIndex as Integer +Dim MaxModuleIndex as Integer +Dim bMacroExists as Boolean +Dim n as Integer +Dim m as Integer +Dim LibName as String +Dim sBasicCode as String +Dim oLibrary as Object + bMacroExists = False + bMacroExists = oBasicLibraries.hasElements + If bMacroExists Then + MaxLibIndex = Ubound(oBasicLibraries.ElementNames()) + For n = 0 To MaxLibIndex + LibName = oBasicLibraries.ElementNames(n) + If oBasicLibraries.isLibraryLoaded(LibName) Then + oLibrary = oBasicLibraries.getbyName(LibName) + If oLibrary.hasElements() Then + MaxModuleIndex = Ubound(oLibrary.ElementNames()) + For m = 0 To MaxModuleIndex + ModuleName = oLibrary.ElementNames(m) + sBasicCode = oLibrary.getbyName(ModuleName) + If sBasicCode <> "" Then + ConcatComment(sComment, sReeditMacro) + CheckIfMacroExists() = True + Exit Function + End If + Next m + End If + End If + Next n + End If + CheckIfMacroExists() = False +End Function + + + +Function CheckPassWordProtection(oDocument as Object) +Dim bIsPassWordProtected as Boolean +Dim i as Integer +Dim oArgs() +Dim MaxIndex as Integer +Dim sblabla as String + bIsPassWordProtected = false + oArgs() = oDocument.getArgs() + MaxIndex = Ubound(oArgs()) + For i = 0 To MaxIndex + sblabla = oArgs(i).Name + If oArgs(i).Name = "Password" Then + bIsPassWordProtected = True + sCurPassWord = oArgs(i).Value + Exit For + End If + Next i + CheckPassWordProtection() = bIsPassWordProtected +End Function + + +Sub OpenLogDocument() + + bShowLogFile = True + ImportDialogArea.endexecute() + +End Sub + + +Sub MergeRange(oTable as Object, oCell as Object, MergeCount as Integer) +Dim oTableCursor as Object + oTableCursor = oTable.createCursorByCellName(oCell.CellName) + oTableCursor.goRight(MergeCount, True) + oTableCursor.mergeRange() +End Sub + + +Function ConcatComment(sComment as String, AdditionalComment as String) + If sComment = "" Then + sComment = AdditionalComment + Else + sComment = sComment & chr(13) + AdditionalComment + End If + ConcatComment = sComment +End Function + diff --git a/wizards/source/importwizard/ImportDialog.xdl b/wizards/source/importwizard/ImportDialog.xdl new file mode 100644 index 000000000..1f3fc71ff --- /dev/null +++ b/wizards/source/importwizard/ImportDialog.xdl @@ -0,0 +1,97 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/importwizard/Language.xba b/wizards/source/importwizard/Language.xba new file mode 100644 index 000000000..bd890ed63 --- /dev/null +++ b/wizards/source/importwizard/Language.xba @@ -0,0 +1,150 @@ + + + +Option Explicit + +Public sMSTemplateCheckbox(2) As String +Public sMSDocumentCheckbox(2) As String +Public sTemplateCheckbox(SBMAXAPPLCOUNT-1) As String +Public sDocumentCheckbox(SBMAXAPPLCOUNT-1) As String +Public sTemplateGroupName As String +Public sSearchInSubDir as String +Public sPathErrorTemplates(SBMAXAPPLCOUNT-1) As String +Public sPathErrorDocument(SBMAXAPPLCOUNT-1) As String +Public sPathErrorStarDoc(SBMAXAPPLCOUNT-1) As String +Public sStarDocLabel(SBMAXAPPLCOUNT-1) As String +Public sImportLabel As String, sExportLabel As String +Public SOApplicationName(5) As String +Public sHelpButton As String, sCancelButton As String, sBackButton As String, sNextButton As String +Public sSumInclusiveSubDir As String, sSumSaveDocuments As String +Public sSummaryHeader As String +Public sWelcometextLabel1 As String, sWelcometextLabel3 As String +Public sBeginButton As String, sMsgDirNotThere As String +Public sQueryForNewCreation As String, sPathError3 As String +Public sNoDirCreation As String +Public sProgressMoreDocs As String, sProgressMoreTemplates as String +Public sFileExists As String, sMorePathsError3 As String +Public sConvertError1 As String, sConvertError2 As String, sPathDialogMessage As String +Public sRTErrorDesc As String, sRTErrorHeader As String +Public sProgressPage_1 As String, sProgressPage_2 As String, sProgressPage_3 as String +Public sProgressFound as String, sProgresspage_5 as String +Public sContainerName(1) as String +Public sReady as String, sTitle as String +Public sCloseButton as String +Public sSourceDocuments as String +Public sTargetDocuments as String +Public sSumMSDocuments(3) as String +Public sSumMSTemplates(3) as String +Public ModuleList(3) as String +Public sLogSummary as String +Public sReeditMacro as String +Public sOverwriteallFiles as String +Public sCouldnotopenDocument as String +Public sCurcouldnotopenDocument as String +Public sCouldnotsaveDocument as String +Public sCurcouldnotsaveDocument as String + + +Sub LoadLanguage() + If InitResources("ImportWizard") then + sHelpButton = GetResText("HelpButton") + sCancelButton = GetResText("CancelButton") + sBackButton = GetResText("BackButton") + sNextButton = GetResText("NextButton") + sBeginButton = GetResText("BeginButton") + sCloseButton = GetResText("CloseButton") + + sWelcometextLabel1 = ReplaceString(GetResText("WelcometextLabel1"), GetProductName(),"%PRODUCTNAME") + sWelcometextLabel3 = GetResText("WelcometextLabel3") + + ' Microsoft Documents + sMSTemplateCheckBox(0) = GetResText("MSTemplateCheckbox_1_") + sMSTemplateCheckBox(1) = GetResText("MSTemplateCheckbox_2_") + sMSTemplateCheckBox(2) = GetResText("MSTemplateCheckbox_3_") + + ' DocumentCheckbox- Captions + sMSDocumentCheckBox(0) = GetResText("MSDocumentCheckbox_1_") + sMSDocumentCheckBox(1) = GetResText("MSDocumentCheckbox_2_") + sMSDocumentCheckBox(2) = GetResText("MSDocumentCheckbox_3_") + + 'StarOffice Applicationnames + + sContainerName(0) = GetResText("MSContainerName") + + sSummaryHeader = GetResText("SummaryHeader") + + sTemplateGroupName = GetResText("GroupnameDefault") + + sProgressMoreDocs = GetResText("ProgressMoreDocs") + sProgressMoreTemplates = GetResText("ProgressMoreTemplates") + sNoDirCreation = GetResText("NoDirCreation") + sMsgDirNotThere = GetResText("MsgDirNotThere") + sQueryForNewCreation = GetResText("QueryfornewCreation") + sFileExists = GetResText("FileExists") + sMorePathsError3 = GetResText("MorePathsError3") + sConvertError1 = GetResText("ConvertError1") + sConvertError2 = GetResText("ConvertError2") + sRTErrorDesc = GetResText("RTErrorDesc") + sRTErrorHeader = GetResText("RTErrorHeader") + sOverwriteallFiles = GetResText("OverwriteallFiles") + sReeditMacro = GetResText("ReeditMacro") + sCouldnotsaveDocument = GetResText("CouldNotsaveDocument") + sCouldnotopenDocument = GetResText("CouldNotopenDocument") + sPathDialogMessage = GetResText("PathDialogMessage") + sTitle = GetResText("DialogTitle") + + sProgressPage_1 = GetResText("ProgressPage1") + sProgressPage_2 = GetResText("ProgressPage2") + sProgressPage_3 = GetResText("ProgressPage3") + sProgressFound = GetResText("ProgressFound") + sProgressPage_5 = GetResText("ProgressPage5") + sReady = GetResText("Ready") + sSourceDocuments = GetResText("SourceDocuments") + sTargetDocuments = GetResText("TargetDocuments") + sLogSummary = GetResText("LogfileSummary") + sSumInclusiveSubDir = GetResText("SumInclusiveSubDir") + sSumSaveDocuments = GetResText("SumSaveDokumente") + sSumMSDocuments(0) = GetResText("SumMSTextDocuments") + sSumMSDocuments(1) = GetResText("SumMSTableDocuments") + sSumMSDocuments(2) = GetResText("SumMSDrawDocuments") + sSumMSTemplates(0) = GetResText("SumMSTextTemplates") + sSumMSTemplates(1) = GetResText("SumMSTableTemplates") + sSumMSTemplates(2) = GetResText("SumMSDrawTemplates") + With ImportDialog + sImportLabel = GetResText("TextImportLabel") + sExportLabel = GetResText("TextExportLabel") + sSearchInSubDir = GetResText("SearchInSubDir") + .chkTemplateSearchSubDir.Label = sSearchInSubDir + .lblDocumentImport.Label = sImportLabel + .lblDocumentExport.Label = sExportLabel + .chkDocumentSearchSubDir.Label = sSearchInSubDir + .lblTemplateImport.Label = sImportLabel + .lblTemplateExport.Label = sExportLabel + .chkLogfile.Label = GetResText("CreateLogfile") + .chkLogfile.Helptext = GetResText("LogfileHelpText") + .cmdShowLogFile.Label = GetResText("ShowLogfile") + End With + ModuleList(0) = "com.sun.star.text.TextDocument" + ModuleList(1) = "com.sun.star.sheet.SpreadsheetDocument" + ModuleList(2) = "com.sun.star.drawing.DrawingDocument/com.sun.star.presentation.PresentationDocument" + ModuleList(3) = "com.sun.star.formula.FormulaProperties/com.sun.star.text.GlobalDocument" + End If +End Sub + + diff --git a/wizards/source/importwizard/Main.xba b/wizards/source/importwizard/Main.xba new file mode 100644 index 000000000..b8cc8211e --- /dev/null +++ b/wizards/source/importwizard/Main.xba @@ -0,0 +1,291 @@ + + + +Option Explicit +REM ***** BASIC ***** + +Public HeaderPreviews(4) as Object +Public ImportDialog as Object +Public ImportDialogArea as Object +Public oFactoryKey as Object +Public bShowLogFile as Boolean + +' If the ProgressPage is already on Top The Dialog will be immediately closed when this flag is +' set to False +Public bConversionIsRunning as Boolean +Public RetValue as Integer + +Sub Main() + Dim NoArgs() as New com.sun.star.beans.PropertyValue + bShowLogFile=FALSE + If Not bDebugWizard Then + On Local Error Goto RTError + End If + BasicLibraries.LoadLibrary("Tools") + RetValue = 10 + bIsFirstLogTable = True + bConversionIsRunning = False + sCRLF = CHR(13) & CHR(10) + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + oFactoryKey = GetRegistryKeyContent("org.openoffice.Setup/Office/Factories") + If GetImportWizardPaths() = False Then + Exit Sub + End If + bCancelTask = False + bDoKeepApplValues = False + CurOffice = 0 + ImportDialogArea = LoadDialog("ImportWizard","ImportDialog") + ImportDialog = ImportDialogArea.Model + LoadLanguage() + WizardMode = SBMICROSOFTMODE + MaxApplCount = 3 + FillStep_Welcome() + RepaintHeaderPreview() + ImportDialog.ImportPreview.BackGroundColor = RGB(0,60,126) + ImportDialog.cmdGoOn.DefaultButton = True + ImportDialogArea.GetControl("optMSDocuments").SetFocus() + ToggleCheckboxesWithBoolean(True) + + RetValue = ImportDialogArea.Execute() + If bShowLogFile=TRUE Then + OpenDocument(sLogUrl, NoArgs()) + End if + If RetValue = 0 Then + CancelTask() + End If + ImportDialogArea.Dispose() + End + Exit Sub +RTError: + Msgbox sRTErrorDesc, 16, sRTErrorHeader +End Sub + + +Sub NextStep() +Dim iCurStep as Integer + If Not bDebugWizard Then + On Error Goto RTError + End If + bConversionIsRunning = False + iCurStep = ImportDialog.Step + Select Case iCurStep + Case 1 + FillStep_InputPaths(0, True) + Case 2 + If CheckInputPaths Then + SaveStep_InputPath + If CurOffice < ApplCount - 1 Then + CurOffice = CurOffice + 1 + TakeOverPathSettings() + FillStep_InputPaths(CurOffice, False) + Else + FillStep_Summary() + End If + End If + Case 3 + FillStep_Progress() + Select Case WizardMode + Case SBMICROSOFTMODE + Call ConvertAllDocuments(MSFilterName()) + End Select + Case 4 + CancelTask(True) + End Select + + If ((ImportDialog.chkLogfile.State <> 1) OR (iCurStep <> 3)) Then + ImportDialog.cmdGoOn.DefaultButton = True + End If + + RepaintHeaderPreview() + Exit Sub +RTError: + Msgbox sRTErrorDesc, 16, sRTErrorHeader +End Sub + + +Sub PrevStep() +Dim iCurStep as Integer + If Not bDebugWizard Then + On Error Goto RTError + End If + bConversionIsRunning = False + iCurStep = ImportDialog.Step + Select Case iCurStep + Case 4 + ImportDialog.cmdCancel.Label = sCancelButton + FillStep_Summary() + Case 3 + FillStep_InputPaths(Applcount-1, False) + Case 2 + SaveStep_InputPath + If CurOffice > 0 Then + CurOffice = CurOffice - 1 + FillStep_InputPaths(CurOffice, False) + Else + FillStep_Welcome() + ToggleCheckboxesWithBoolean(True) + bDoKeepApplValues = True + End If + End Select + ImportDialog.cmdGoOn.DefaultButton = True + RepaintHeaderPreview() + Exit Sub +RTError: + Msgbox sRTErrorDesc, 16, sRTErrorHeader +End Sub + + +Sub CancelTask() + If bConversionIsRunning Then + If Msgbox(sConvertError1, 36, sConvertError2) = 6 Then + bCancelTask = True + bInterruptSearch = True + Else + bCancelTask = False + ImportDialog.cmdCancel.Enabled = True + End If + Else + ImportDialogArea.EndExecute() + End If +End Sub + + +Sub TemplateDirSearchDialog() + CallDirSearchDialog(ImportDialog.TemplateImportPath) +End Sub + + +Sub RepaintHeaderPreview() +Dim Bitmap As Object +Dim CurStep as Integer +Dim sBitmapPath as String +Dim LocPrefix as String + CurStep = ImportDialog.Step + LocPrefix = WizardMode + LocPrefix = ReplaceString(LocPrefix,"XML", "SO") + If CurStep = 2 Then + sBitmapPath = SOBitmapPath & LocPrefix & "-Import_" & CurStep & "-" & Applications(CurOffice,SBAPPLKEY) + 1 & ".png" + Else + sBitmapPath = SOBitmapPath & "Import_" & CurStep & ".png" + End If + ImportDialog.ImportPreview.ImageURL = sBitmapPath +End Sub + + +Sub CheckModuleInstallation() +Dim i as Integer + For i = 1 To MaxApplCount + ImportDialogArea.GetControl("chk" & WizardMode & "Application" & i).Model.Enabled = Abs(CheckInstalledModule(i-1)) + Next i +End Sub + + +Function CheckInstalledModule(Index as Integer) as Boolean +Dim ModuleName as String +Dim NameList() as String +Dim MaxIndex as Integer +Dim i as Integer + ModuleName = ModuleList(Index) + If Instr(1,ModuleName,"/") <> 0 Then + CheckInstalledModule() = False + NameList() = ArrayoutOfString(ModuleName,"/", MaxIndex) + For i = 0 To MaxIndex + If oFactoryKey.HasByName(NameList(i)) Then + CheckInstalledModule() = True + End If + Next i + Else + CheckInstalledModule() = oFactoryKey.HasByName(ModuleName) + End If +End Function + + +Sub ToggleCheckboxes(oEvent as Object) +Dim bMSEnable as Boolean + WizardMode = oEvent.Source.Model.Tag + bMSEnable = WizardMode = "MS" + ToggleCheckboxesWithBoolean(bMSEnable) +End Sub + + +Sub ToggleCheckboxesWithBoolean(bMSEnable as Boolean) + If bMSEnable = True Then + WizardMode = SBMICROSOFTMODE + MaxApplCount = 3 + Else + 'Not supposed to happen - is there an assert in BASIC... + End If + With ImportDialogArea + .GetControl("chkMSApplication1").Model.Enabled = bMSEnable + .GetControl("chkMSApplication2").Model.Enabled = bMSEnable + .GetControl("chkMSApplication3").Model.Enabled = bMSEnable + End With + CheckModuleInstallation() + bDoKeepApplValues = False + ToggleNextButton() +End Sub + + +Sub ToggleNextButton() +Dim iCurStep as Integer +Dim bDoEnable as Boolean +Dim i as Integer + iCurStep = ImportDialog.Step + Select Case iCurStep + Case 1 + With ImportDialog + If .optMSDocuments.State = 1 Then + bDoEnable = .chkMSApplication1.State = 1 Or .chkMSApplication2.State = 1 Or .chkMSApplication3.State = 1 + End If + End With + bDoKeepApplValues = False + Case 2 + bDoEnable = CheckControlPath(ImportDialog.chkTemplatePath, ImportDialog.txtTemplateImportPath, True) + bDoEnable = CheckControlPath(ImportDialog.chkDocumentPath, ImportDialog.txtDocumentImportPath, bDoEnable) + End Select + ImportDialog.cmdGoOn.Enabled = bDoEnable +End Sub + + +Sub TakeOverPathSettings() +'Takes over the Pathsettings from the first selected application to the next applications + If Applications(CurOffice,SBDOCSOURCE) = "" Then + Applications(CurOffice,SBDOCSOURCE) = Applications(0,SBDOCSOURCE) + Applications(CurOffice,SBDOCTARGET) = Applications(0,SBDOCTARGET) + Applications(CurOffice,SBTEMPLSOURCE) = Applications(0,SBTEMPLSOURCE) + Applications(CurOffice,SBTEMPLTARGET) = Applications(0,SBTEMPLTARGET) + End If +End Sub + + +Function GetImportWizardPaths() as Boolean + SOBitmapPath = GetOfficeSubPath("Template", "../wizard/bitmap") + If SOBitmapPath <> "" Then + SOWorkPath = GetPathSettings("Work", False) + If SOWorkPath <> "" Then + SOTemplatePath = GetPathSettings("Template_writable",False,0) + If SOTemplatePath <> "" Then + GetImportWizardPaths() = True + Exit Function + End If + End If + End If + GetImportWizardPaths() = False +End Function + diff --git a/wizards/source/importwizard/dialog.xlb b/wizards/source/importwizard/dialog.xlb new file mode 100644 index 000000000..f5cc021d5 --- /dev/null +++ b/wizards/source/importwizard/dialog.xlb @@ -0,0 +1,5 @@ + + + + + diff --git a/wizards/source/importwizard/script.xlb b/wizards/source/importwizard/script.xlb new file mode 100644 index 000000000..2d10f65cb --- /dev/null +++ b/wizards/source/importwizard/script.xlb @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/wizards/source/resources/resources_en_US.properties b/wizards/source/resources/resources_en_US.properties new file mode 100644 index 000000000..32f9104e9 --- /dev/null +++ b/wizards/source/resources/resources_en_US.properties @@ -0,0 +1,579 @@ +# +# This file is part of the LibreOffice project. +# +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# This file incorporates work covered by the following license notice: +# +# Licensed to the Apache Software Foundation (ASF) under one or more +# contributor license agreements. See the NOTICE file distributed +# with this work for additional information regarding copyright +# ownership. The ASF licenses this file to you under the Apache +# License, Version 2.0 (the "License; you may not use this file +# except in compliance with the License. You may obtain a copy of +# the License at http://www.apache.org/licenses/LICENSE-2.0 . +# +# x-no-translate + +# +# resources.properties +# +# resources for com.sun.star.wizards +# +RID_COMMON_0=The directory '%1' could not be created.
There may not be enough space left on your hard disk. +RID_COMMON_1=The text document could not be created.
Please check if the module 'PRODUCTNAME Writer' is installed. +RID_COMMON_2=The spreadsheet could not be created.
Please check if the module 'PRODUCTNAME Calc' is installed. +RID_COMMON_3=The presentation could not be created.
Please check if the module 'PRODUCTNAME Impress' is installed. +RID_COMMON_4=The drawing could not be created.
Please check if the module 'PRODUCTNAME Draw' is installed. +RID_COMMON_5=The formula could not be created.
Please check if the module 'PRODUCTNAME Math' is installed. +RID_COMMON_6=The files required could not be found.
Please start the %PRODUCTNAME Setup and choose 'Repair'. +RID_COMMON_7=The file '' already exists.

Would you like to overwrite the existing file? +RID_COMMON_8=Yes +RID_COMMON_9=Yes to All +RID_COMMON_10=No +RID_COMMON_11=Cancel +RID_COMMON_12=~Finish +RID_COMMON_13=< ~Back +RID_COMMON_14=~Next > +RID_COMMON_15=~Help +RID_COMMON_16=Steps +RID_COMMON_17=Close +RID_COMMON_18=OK +RID_COMMON_19=The file already exists. Do you want to overwrite it? +RID_COMMON_20=Template created via on . +RID_COMMON_21=The wizard could not be run, because important files were not found.\nUnder 'Tools - Options - %PRODUCTNAME - Paths' click the 'Default' button to reset the paths to the original default settings.\nThen run the wizard again. +RID_REPORT_0=Report Wizard +RID_REPORT_3=~Table +RID_REPORT_4=Colu~mns +RID_REPORT_7=Report_ +RID_REPORT_8=- undefined - +RID_REPORT_9=~Fields in report +RID_REPORT_11=Grouping +RID_REPORT_12=Sort options +RID_REPORT_13=Choose layout +RID_REPORT_14=Create report +RID_REPORT_15=Layout of data +RID_REPORT_16=Layout of headers and footers +RID_REPORT_19=Fields +RID_REPORT_20=~Sort by +RID_REPORT_21=T~hen by +RID_REPORT_22=Orientation +RID_REPORT_23=Portrait +RID_REPORT_24=Landscape +RID_REPORT_28=Which fields do you want to have in your report? +RID_REPORT_29=Do you want to add grouping levels? +RID_REPORT_30=According to which fields do you want to sort the data? +RID_REPORT_31=How do you want your report to look? +RID_REPORT_32=Decide how you want to proceed +RID_REPORT_33=Title of report +RID_REPORT_34=Display report +RID_REPORT_35=Create report +RID_REPORT_36=Ascending +RID_REPORT_37=Descending +RID_REPORT_40=~Dynamic report +RID_REPORT_41=~Create report now +RID_REPORT_42=~Modify report layout +RID_REPORT_43=Static report +RID_REPORT_44=Save as +RID_REPORT_50=Groupings +RID_REPORT_51=Then b~y +RID_REPORT_52=~Then by +RID_REPORT_53=Asc~ending +RID_REPORT_54=Ascend~ing +RID_REPORT_55=Ascendin~g +RID_REPORT_56=De~scending +RID_REPORT_57=Des~cending +RID_REPORT_58=De~scending +RID_REPORT_60=Binary fields cannot be displayed in the report. +RID_REPORT_61=The table '' does not exist. +RID_REPORT_62=Creating Report... +RID_REPORT_63=Number of records inserted: +RID_REPORT_64=The form '' does not exist. +RID_REPORT_65=The query with the statement
''
could not be run.
Check your data source. +RID_REPORT_66=The following hidden control in the form '' could not be read: ''. +RID_REPORT_67=Importing data... +RID_REPORT_68=Labeling fields +RID_REPORT_69=How do you want to label the fields? +RID_REPORT_70=Label +RID_REPORT_71=Field +RID_REPORT_72=An error occurred in the wizard.
The template '%PATH' could be erroneous.
Either the required sections or tables do not exist or exist under the wrong name.
See the Help for more detailed information.
Please select another template. +RID_REPORT_73=There is an invalid user field in a table. +RID_REPORT_74=The sort criterion '' was chosen twice. Each criterion can only be chosen once. +RID_REPORT_75=Note: The dummy text will be replaced by data from the database when the report is created. +RID_REPORT_76=A report '%REPORTNAME' already exists in the database. Please assign another name. +RID_REPORT_78=How do you want to proceed after creating the report? +RID_REPORT_79=What kind of report do you want to create? +RID_REPORT_80=Tabular +RID_REPORT_81=Columnar, single-column +RID_REPORT_82=Columnar, two columns +RID_REPORT_83=Columnar, three columns +RID_REPORT_84=In blocks, labels left +RID_REPORT_85=In blocks, labels above +RID_REPORT_86=Title: +RID_REPORT_87=Author: +RID_REPORT_88=Date: +# Please don't translate the words #page# and #count#, these are placeholders. +RID_REPORT_89=Page #page# of #count# +RID_REPORT_90=Page number: +RID_REPORT_91=Page count: +RID_REPORT_92=No valid report template was found. +RID_REPORT_93=Page: +RID_REPORT_94=Align Left - Border +RID_REPORT_95=Align Left - Compact +RID_REPORT_96=Align Left - Elegant +RID_REPORT_97=Align Left - Highlighted +RID_REPORT_98=Align Left - Modern +RID_REPORT_99=Align Left - Red & Blue +RID_REPORT_100=Default +RID_REPORT_101=Outline - Borders +RID_REPORT_102=Outline - Compact +RID_REPORT_103=Outline - Elegant +RID_REPORT_104=Outline - Highlighted +RID_REPORT_105=Outline - Modern +RID_REPORT_106=Outline - Red & Blue +RID_REPORT_107=Outline, indented - Borders +RID_REPORT_108=Outline, indented - Compact +RID_REPORT_109=Outline, indented - Elegant +RID_REPORT_110=Outline, indented - Highlighted +RID_REPORT_111=Outline, indented - Modern +RID_REPORT_112=Outline, indented - Red & Blue +RID_REPORT_113=Bubbles +RID_REPORT_114=Cinema +RID_REPORT_115=Controlling +RID_REPORT_116=Default +RID_REPORT_117=Drafting +RID_REPORT_118=Finances +RID_REPORT_119=Flipchart +RID_REPORT_120=Formal with Company Logo +RID_REPORT_121=Generic +RID_REPORT_122=Worldmap +RID_DB_COMMON_0=C~reate +RID_DB_COMMON_1=~Cancel +RID_DB_COMMON_2=< ~Back +RID_DB_COMMON_3=~Next > +RID_DB_COMMON_4=~Database +RID_DB_COMMON_5=~Table name +RID_DB_COMMON_6=An error occurred while running the wizard. The wizard will be terminated. +RID_DB_COMMON_8=No database has been installed. At least one database is required before the wizard for forms can be started. +RID_DB_COMMON_9=The database does not contain any tables. +RID_DB_COMMON_10=This title already exists in the database. Please enter another name. +RID_DB_COMMON_11=The title must not contain any spaces or special characters. +RID_DB_COMMON_12=The database service (com.sun.data.DatabaseEngine) could not be instantiated. +RID_DB_COMMON_13=The selected table or query could not be opened. +RID_DB_COMMON_14=No connection to the database could be established. +RID_DB_COMMON_20=~Help +RID_DB_COMMON_21=~Stop +RID_DB_COMMON_30=The document could not be saved. +RID_DB_COMMON_33=Exiting the wizard +RID_DB_COMMON_34=Connecting to data source... +RID_DB_COMMON_35=The connection to the data source could not be established. +RID_DB_COMMON_36=The file path entered is not valid. +RID_DB_COMMON_37=Please select a data source +RID_DB_COMMON_38=Please select a table or query +RID_DB_COMMON_39=Add field +RID_DB_COMMON_40=Remove field +RID_DB_COMMON_41=Add all fields +RID_DB_COMMON_42=Remove all fields +RID_DB_COMMON_43=Move field up +RID_DB_COMMON_44=Move field down +RID_DB_COMMON_45=The field names from '%NAME' could not be retrieved. +RID_QUERY_0=Query Wizard +RID_QUERY_1=Query +RID_QUERY_2=Query Wizard +RID_QUERY_3=~Tables +RID_QUERY_4=A~vailable fields +RID_QUERY_5=Name ~of the query +RID_QUERY_6=Display ~Query +RID_QUERY_7=~Modify Query +RID_QUERY_8=~How do you want to proceed after creating the query? +RID_QUERY_9=Match ~all of the following +RID_QUERY_10=~Match any of the following +RID_QUERY_11=~Detailed query (Shows all records of the query.) +RID_QUERY_12=~Summary query (Shows only results of aggregate functions.) +RID_QUERY_16=Aggregate functions +RID_QUERY_17=Fields +RID_QUERY_18=~Group by +RID_QUERY_19=Field +RID_QUERY_20=Alias +RID_QUERY_21=Table: +RID_QUERY_22=Query: +RID_QUERY_24=Condition +RID_QUERY_25=Value +RID_QUERY_26=is equal to +RID_QUERY_27=is not equal to +RID_QUERY_28=is smaller than +RID_QUERY_29=is greater than +RID_QUERY_30=is equal or less than +RID_QUERY_31=is equal or greater than +RID_QUERY_32=like +RID_QUERY_33=not like +RID_QUERY_34=is null +RID_QUERY_35=is not null +RID_QUERY_36=true +RID_QUERY_37=false +RID_QUERY_38=and +RID_QUERY_39=or +RID_QUERY_40=get the sum of +RID_QUERY_41=get the average of +RID_QUERY_42=get the minimum of +RID_QUERY_43=get the maximum of +RID_QUERY_44=get the count of +RID_QUERY_48=(none) +RID_QUERY_50=Fie~lds in the Query: +RID_QUERY_51=Sorting order: +RID_QUERY_52=No sorting fields were assigned. +RID_QUERY_53=Search conditions: +RID_QUERY_54=No conditions were assigned. +RID_QUERY_55=Aggregate functions: +RID_QUERY_56=No aggregate functions were assigned. +RID_QUERY_57=Grouped by: +RID_QUERY_58=No Groups were assigned. +RID_QUERY_59=Grouping conditions: +RID_QUERY_60=No grouping conditions were assigned. +RID_QUERY_70=Select the fields (columns) for your query +RID_QUERY_71=Select the sorting order +RID_QUERY_72=Select the search conditions +RID_QUERY_73=Select the type of query +RID_QUERY_74=Select the groups +RID_QUERY_75=Select the grouping conditions +RID_QUERY_76=Assign aliases if desired +RID_QUERY_77=Check the overview and decide how to proceed +RID_QUERY_80=Field selection +RID_QUERY_81=Sorting order +RID_QUERY_82=Search conditions +RID_QUERY_83=Detail or summary +RID_QUERY_84=Grouping +RID_QUERY_85=Grouping conditions +RID_QUERY_86=Aliases +RID_QUERY_87=Overview +RID_QUERY_88=A field that has not been assigned an aggregate function must be used in a group. +RID_QUERY_89=The condition ' ' was chosen twice. Each condition can only be chosen once +RID_QUERY_90=The aggregate function has been assigned twice to the fieldname ''. +RID_QUERY_91=, +RID_QUERY_92= () +RID_QUERY_93= () +RID_QUERY_94= +RID_QUERY_95= +RID_QUERY_96= +RID_FORM_0=Form Wizard +RID_FORM_1=Fields in ~the form +RID_FORM_2=Binary fields are always listed and selectable from the left list.\nIf possible, they are interpreted as images. +RID_FORM_3=A subform is a form that is inserted in another form.\nUse subforms to show data from tables or queries with a one-to-many relationship. +RID_FORM_4=~Add Subform +RID_FORM_5=~Subform based on existing relation +RID_FORM_6=Tables or queries +RID_FORM_7=Subform based on ~manual selection of fields +RID_FORM_8=~Which relation do you want to add? +RID_FORM_9=Fields in the ~subform +RID_FORM_12=~Available fields +RID_FORM_13=Fields in form +RID_FORM_19=The join '' and '' has been selected twice.\nBut joins may only be used once. +RID_FORM_20=~First joined subform field +RID_FORM_21=~Second joined subform field +RID_FORM_22=~Third joined subform field +RID_FORM_23=~Fourth joined subform field +RID_FORM_24=F~irst joined main form field +RID_FORM_25=S~econd joined main form field +RID_FORM_26=T~hird joined main form field +RID_FORM_27=F~ourth joined main form field +RID_FORM_28=Field border +RID_FORM_29=No border +RID_FORM_30=3D look +RID_FORM_31=Flat +RID_FORM_32=Label placement +RID_FORM_33=Align left +RID_FORM_34=Align right +RID_FORM_35=Arrangement of DB fields +RID_FORM_36=Columnar - Labels Left +RID_FORM_37=Columnar - Labels on Top +RID_FORM_38=In Blocks - Labels Left +RID_FORM_39=In Blocks - Labels Above +RID_FORM_40=As Data Sheet +RID_FORM_41=Arrangement of the main form +RID_FORM_42=Arrangement of the subform +RID_FORM_44=The form is to be ~used for entering new data only. +RID_FORM_45=Existing data will not be displayed +RID_FORM_46=T~he form is to display all data +RID_FORM_47=Do not allow ~modification of existing data +RID_FORM_48=Do not allow ~deletion of existing data +RID_FORM_49=Do not allow ~addition of new data +RID_FORM_50=Name of ~the form +RID_FORM_51=How do you want to proceed after creating the form? +RID_FORM_52=~Work with the form +RID_FORM_53=~Modify the form +RID_FORM_55=~Page Styles +RID_FORM_80=Field selection +RID_FORM_81=Set up a subform +RID_FORM_82=Add subform fields +RID_FORM_83=Get joined fields +RID_FORM_84=Arrange controls +RID_FORM_85=Set data entry +RID_FORM_86=Apply styles +RID_FORM_87=Set name +RID_FORM_88=(Date) +RID_FORM_89=(Time) +RID_FORM_90=Select the fields of your form +RID_FORM_91=Decide if you want to set up a subform +RID_FORM_92=Select the fields of your subform +RID_FORM_93=Select the joins between your forms +RID_FORM_94=Arrange the controls on your form +RID_FORM_95=Select the data entry mode +RID_FORM_96=Apply the style of your form +RID_FORM_97=Set the name of the form +RID_FORM_98=A form with the name '%FORMNAME' already exists.\nChoose another name. +RID_TABLE_1=Table Wizard +RID_TABLE_2=Select fields +RID_TABLE_3=Set types and formats +RID_TABLE_4=Set primary key +RID_TABLE_5=Create table +RID_TABLE_8=Select fields for your table +RID_TABLE_9=Set field types and formats +RID_TABLE_10=Set primary key +RID_TABLE_11=Create table +RID_TABLE_14=This wizard helps you to create a table for your database. After selecting a table category and a sample table, choose the fields you want to include in your table. You can include fields from more than one sample table. +RID_TABLE_15=Ca~tegory +RID_TABLE_16=B~usiness +RID_TABLE_17=P~ersonal +RID_TABLE_18=~Sample tables +RID_TABLE_19=A~vailable fields +RID_TABLE_20=Field information +RID_TABLE_21=+ +RID_TABLE_22=- +RID_TABLE_23=Field name +RID_TABLE_24=Field type +RID_TABLE_25=~Selected fields +RID_TABLE_26=A primary key uniquely identifies each record in a database table. Primary keys ease the linking of information in separate tables, and it is recommended that you have a primary key in every table. Without a primary key, it will not be possible to enter data into this table. +RID_TABLE_27=~Create a primary key +RID_TABLE_28=~Automatically add a primary key +RID_TABLE_29=~Use an existing field as a primary key +RID_TABLE_30=Define p~rimary key as a combination of several fields +RID_TABLE_31=F~ieldname +RID_TABLE_32=~Primary key fields +RID_TABLE_33=Auto ~value +RID_TABLE_34=What do you want to name your table? +RID_TABLE_35=Congratulations. You have entered all the information needed to create your table. +RID_TABLE_36=What do you want to do next? +RID_TABLE_37=Modify the table design +RID_TABLE_38=Insert data immediately +RID_TABLE_39=C~reate a form based on this table +RID_TABLE_40=The table you have created could not be opened. +RID_TABLE_41=The table name '%TABLENAME' contains a character ('%SPECIALCHAR') that might not be supported by the database. +RID_TABLE_42=The field name '%FIELDNAME' contains a special character ('%SPECIALCHAR') that might not be supported by the database. +RID_TABLE_43=Field +RID_TABLE_44=MyTable +RID_TABLE_45=Add a Field +RID_TABLE_46=Remove the selected Field +RID_TABLE_47=The field cannot be inserted because this would exceed the maximum number of %COUNT possible fields in the database table +RID_TABLE_48=The name '%TABLENAME' already exists.\nPlease enter another name. +RID_TABLE_49=Catalog of the table +RID_TABLE_50=Schema of the table +RID_TABLE_51=The field '%FIELDNAME' already exists. +STEP_ZERO_0=~Cancel +STEP_ZERO_1=~Help +STEP_ZERO_2=< ~Back +STEP_ZERO_3=~Convert +STEP_ZERO_4=Note: Currency amounts from external links and currency conversion factors in formulas cannot be converted. +STEP_ZERO_5=First, unprotect all sheets. +STEP_ZERO_6=Currencies: +STEP_ZERO_7=C~ontinue > +STEP_ZERO_8=C~lose +STEP_CONVERTER_0=~Entire document +STEP_CONVERTER_1=Selection +STEP_CONVERTER_2=Cell S~tyles +STEP_CONVERTER_3=Currency cells in the current ~sheet +STEP_CONVERTER_4=Currency cells in the entire ~document +STEP_CONVERTER_5=~Selected range +STEP_CONVERTER_6=Select Cell Styles +STEP_CONVERTER_7=Select currency cells +STEP_CONVERTER_8=Currency ranges: +STEP_CONVERTER_9=Templates: +STEP_AUTOPILOT_0=Extent +STEP_AUTOPILOT_1=~Single %PRODUCTNAME Calc document +STEP_AUTOPILOT_2=Complete ~directory +STEP_AUTOPILOT_3=Source Document: +STEP_AUTOPILOT_4=Source directory: +STEP_AUTOPILOT_5=~Including subfolders +STEP_AUTOPILOT_6=Target directory: +STEP_AUTOPILOT_7=Temporarily unprotect sheet without query +STEP_AUTOPILOT_10=Also convert fields and tables in text documents +STATUSLINE_0=Conversion status: +STATUSLINE_1=Conversion status of the cell templates: +STATUSLINE_2=Registration of the relevant ranges: Sheet %1Number%1 of %2TotPageCount%2 +STATUSLINE_3=Entry of the ranges to be converted... +STATUSLINE_4=Sheet protection for each sheet will be restored... +STATUSLINE_5=Conversion of the currency units in the cell templates... +MESSAGES_0=~Finish +MESSAGES_1=Select directory +MESSAGES_2=Select file +MESSAGES_3=Select target directory +MESSAGES_4=non-existent +MESSAGES_5=Euro Converter +MESSAGES_6=Should protected spreadsheets be temporarily unprotected? +MESSAGES_7=Enter the password to unprotect the table %1TableName%1 +MESSAGES_8=Wrong Password! +MESSAGES_9=Protected Sheet +MESSAGES_10=Warning! +MESSAGES_11=Protection for the sheets will not be removed. +MESSAGES_12=Sheet cannot be unprotected +MESSAGES_13=The Wizard cannot edit this document as cell formats cannot be modified in documents containing protected spreadsheets. +MESSAGES_14=Please note that the Euro Converter will, otherwise, not be able to edit this document! +MESSAGES_15=Please choose a currency to be converted first! +MESSAGES_16=Password: +MESSAGES_17=OK +MESSAGES_18=Cancel +MESSAGES_19=Please select a %PRODUCTNAME Calc document for editing! +MESSAGES_20='<1>' is not a directory! +MESSAGES_21=Document is read-only! +MESSAGES_22=The '<1>' file already exists.Do you want to overwrite it? +MESSAGES_23=Do you really want to terminate conversion at this point? +MESSAGES_24=Cancel Wizard +CURRENCIES_0=Portuguese Escudo +CURRENCIES_1=Dutch Guilder +CURRENCIES_2=French Franc +CURRENCIES_3=Spanish Peseta +CURRENCIES_4=Italian Lira +CURRENCIES_5=German Mark +CURRENCIES_6=Belgian Franc +CURRENCIES_7=Irish Punt +CURRENCIES_8=Luxembourg Franc +CURRENCIES_9=Austrian Schilling +CURRENCIES_10=Finnish Mark +CURRENCIES_11=Greek Drachma +CURRENCIES_12=Slovenian Tolar +CURRENCIES_13=Cypriot Pound +CURRENCIES_14=Maltese Lira +CURRENCIES_15=Slovak Koruna +CURRENCIES_16=Estonian Kroon +CURRENCIES_17=Latvian Lats +CURRENCIES_18=Lithuanian Litas +STEP_LASTPAGE_0=Progress +STEP_LASTPAGE_1=Retrieving the relevant documents... +STEP_LASTPAGE_2=Converting the documents... +STEP_LASTPAGE_3=Settings: +STEP_LASTPAGE_4=Sheet is always unprotected +STYLES_0=Theme Selection +STYLES_1=Error while saving the document to the clipboard! The following action cannot be undone. +STYLES_2=~Cancel +STYLES_3=~OK +STYLENAME_0=(Standard) +STYLENAME_1=Autumn Leaves +STYLENAME_2=Be +STYLENAME_3=Black and White +STYLENAME_4=Blackberry Bush +STYLENAME_5=Blue Jeans +STYLENAME_6=Fifties Diner +STYLENAME_7=Glacier +STYLENAME_8=Green Grapes +STYLENAME_9=Marine +STYLENAME_10=Millennium +STYLENAME_11=Nature +STYLENAME_12=Neon +STYLENAME_13=Night +STYLENAME_14=PC Nostalgia +STYLENAME_15=Pastel +STYLENAME_16=Pool Party +STYLENAME_17=Pumpkin +CorrespondenceDialog_0=Addressee +CorrespondenceDialog_1=One recipient +CorrespondenceDialog_2=Several recipients (address database) +CorrespondenceDialog_3=Use of This Template +CorrespondenceMsgError=An error has occurred. +CorrespondenceFields_0=Click placeholder and overwrite +CorrespondenceFields_1=Company +CorrespondenceFields_2=Department +CorrespondenceFields_3=First Name +CorrespondenceFields_4=Last Name +CorrespondenceFields_5=Street +CorrespondenceFields_6=Country +CorrespondenceFields_7=ZIP/Postal Code +CorrespondenceFields_8=City +CorrespondenceFields_9=Title +CorrespondenceFields_10=Position +CorrespondenceFields_11=Form of Address +CorrespondenceFields_12=Initials +CorrespondenceFields_13=Salutation +CorrespondenceFields_14=Home Phone +CorrespondenceFields_15=Work Phone +CorrespondenceFields_16=Fax +CorrespondenceFields_17=Email +CorrespondenceFields_18=URL +CorrespondenceFields_19=Notes +CorrespondenceFields_20=Alt. Field 1 +CorrespondenceFields_21=Alt. Field 2 +CorrespondenceFields_22=Alt. Field 3 +CorrespondenceFields_23=Alt. Field 4 +CorrespondenceFields_24=ID +CorrespondenceFields_25=State +CorrespondenceFields_26=Office Phone +CorrespondenceFields_27=Pager +CorrespondenceFields_28=Mobile Phone +CorrespondenceFields_29=Other Phone +CorrespondenceFields_30=Calendar URL +CorrespondenceFields_31=Invite +CorrespondenceNoTextmark_0=The bookmark 'Recipient' is missing. +CorrespondenceNoTextmark_1=Form letter fields can not be included. +AgendaDlgName=Minutes Template +AgendaDlgNoCancel=An option must be confirmed. +AgendaDlgFrame=Minutes Type +AgendaDlgButton1=Results Minutes +AgendaDlgButton2=Evaluation Minutes +TextField=User data field is not defined! +NoDirCreation=The '%1' directory cannot be created: +MsgDirNotThere=The '%1' directory does not exist. +QueryfornewCreation=Do you want to create it now? +HelpButton=~Help +CancelButton=~Cancel +BackButton=< ~Back +NextButton=Ne~xt > +BeginButton=~Convert +CloseButton=~Close +WelcometextLabel1=This wizard convert legacy format documents to Open Document Format for Office Applications. +WelcometextLabel3=Select the document type for conversion: +MSTemplateCheckbox_1_=Word templates +MSTemplateCheckbox_2_=Excel templates +MSTemplateCheckbox_3_=PowerPoint templates +MSDocumentCheckbox_1_=Word documents +MSDocumentCheckbox_2_=Excel documents +MSDocumentCheckbox_3_=PowerPoint/Publisher documents +MSContainerName=Microsoft Office +SummaryHeader=Summary: +GroupnameDefault=Imported_Templates +ProgressMoreDocs=Documents +ProgressMoreTemplates=Templates +FileExists=The '<1>' file already exists.Do you want to overwrite it? +MorePathsError3=Directories do not exist +ConvertError1=Do you really want to terminate conversion at this point? +ConvertError2=Cancel Wizard +RTErrorDesc=An error has occurred in the wizard. +RTErrorHeader=Error +OverwriteallFiles=Do you want to overwrite documents without being asked? +ReeditMacro=Document macro has to be revised. +CouldNotsaveDocument=Document '<1>' could not be saved. +CouldNotopenDocument=Document '<1>' could not be opened. +PathDialogMessage=Select a directory +DialogTitle=Document Converter +SearchInSubDir=Including subdirectories +ProgressPage1=Progress +ProgressPage2=Retrieving the relevant documents: +ProgressPage3=Converting the documents +ProgressFound=Found: +ProgressPage5="%1 found +Ready=Finished +SourceDocuments=Source documents +TargetDocuments=Target documents +LogfileSummary= documents converted +SumInclusiveSubDir=All subdirectories will be taken into account +SumSaveDokumente=These will be exported to the following directory: +TextImportLabel=Import from: +TextExportLabel=Save to: +CreateLogfile=Create log file +LogfileHelpText=A log file will be created in your work directory +ShowLogfile=Show log file +SumMSTextDocuments=All Word documents contained in the following directory will be imported: +SumMSTableDocuments=All Excel documents contained in the following directory will be imported: +SumMSDrawDocuments=All PowerPoint/Publisher documents contained in the following directory will be imported: +SumMSTextTemplates=All Word templates contained in the following directory will be imported: +SumMSTableTemplates=All Excel templates contained in the following directory will be imported: +SumMSDrawTemplates=All PowerPoint templates contained in the following directory will be imported: diff --git a/wizards/source/scriptforge/SF_Array.xba b/wizards/source/scriptforge/SF_Array.xba new file mode 100644 index 000000000..49bdab147 --- /dev/null +++ b/wizards/source/scriptforge/SF_Array.xba @@ -0,0 +1,2608 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Array +''' ======== +''' Singleton class implementing the "ScriptForge.Array" service +''' Implemented as a usual Basic module +''' Only 1D or 2D arrays are considered. Arrays with more than 2 dimensions are rejected +''' With the noticeable exception of the CountDims method (>2 dims allowed) +''' The first argument of almost every method is the array to consider +''' It is always passed by reference and left unchanged +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_array.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const ARRAYSEQUENCEERROR = "ARRAYSEQUENCEERROR" ' Incoherent arguments +Const ARRAYINSERTERROR = "ARRAYINSERTERROR" ' Matrix and vector have incompatible sizes +Const ARRAYINDEX1ERROR = "ARRAYINDEX1ERROR" ' Given index does not fit in array bounds +Const ARRAYINDEX2ERROR = "ARRAYINDEX2ERROR" ' Given indexes do not fit in array bounds +Const CSVPARSINGERROR = "CSVPARSINGERROR" ' Parsing error detected while parsing a csv file +Const CSVOVERFLOWWARNING = "CSVOVERFLOWWARNING" ' Array becoming too big, import process of csv file is interrupted + +REM ============================================================ MODULE CONSTANTS + +Const MAXREPR = 50 ' Maximum length to represent an array in the console + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_Array Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_Array" +End Property ' ScriptForge.SF_Array.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.Array" +End Property ' ScriptForge.SF_Array.ServiceName + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function Append(Optional ByRef Array_1D As Variant _ + , ParamArray pvArgs() As Variant _ + ) As Variant +''' Append at the end of the input array the items listed as arguments +''' Arguments are appended blindly +''' each of them might be a scalar of any type or a subarray +''' Args +''' Array_1D: the pre-existing array, may be empty +''' pvArgs: a list of items to append to Array_1D +''' Return: +''' the new extended array. Its LBound is identical to that of Array_1D +''' Examples: +''' SF_Array.Append(Array(1, 2, 3), 4, 5) returns (1, 2, 3, 4, 5) + +Dim vAppend As Variant ' Return value +Dim lNbArgs As Long ' Number of elements to append +Dim lMax As Long ' UBound of input array +Dim i As Long +Const cstThisSub = "Array.Append" +Const cstSubArgs = "Array_1D, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vAppend = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + +Try: + lMax = UBound(Array_1D) + lNbArgs = UBound(pvArgs) + 1 ' pvArgs is always zero-based + If lMax < LBound(Array_1D) Then ' Initial array is empty + If lNbArgs > 0 Then + ReDim vAppend(0 To lNbArgs - 1) + End If + Else + vAppend() = Array_1D() + If lNbArgs > 0 Then + ReDim Preserve vAppend(LBound(Array_1D) To lMax + lNbArgs) + End If + End If + For i = 1 To lNbArgs + vAppend(lMax + i) = pvArgs(i - 1) + Next i + +Finally: + Append = vAppend() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Append + +REM ----------------------------------------------------------------------------- +Public Function AppendColumn(Optional ByRef Array_2D As Variant _ + , Optional ByRef Column As Variant _ + ) As Variant +''' AppendColumn appends to the right side of a 2D array a new Column +''' Args +''' Array_2D: the pre-existing array, may be empty +''' If the array has 1 dimension, it is considered as the 1st Column of the resulting 2D array +''' Column: a 1D array with as many items as there are rows in Array_2D +''' Returns: +''' the new extended array. Its LBounds are identical to that of Array_2D +''' Exceptions: +''' ARRAYINSERTERROR +''' Examples: +''' SF_Array.AppendColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 4), (2, 5), (3, 6)) +''' x = SF_Array.AppendColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i + +Dim vAppendColumn As Variant ' Return value +Dim iDims As Integer ' Dimensions of Array_2D +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim lMin As Long ' LBound of Column array +Dim lMax As Long ' UBound of Column array +Dim i As Long +Dim j As Long +Const cstThisSub = "Array.AppendColumn" +Const cstSubArgs = "Array_2D, Column" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vAppendColumn = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array + If Not SF_Utils._ValidateArray(Column, "Column", 1) Then GoTo Finally + End If + iDims = SF_Array.CountDims(Array_2D) + If iDims > 2 Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error + End If + +Try: + lMin = LBound(Column) + lMax = UBound(Column) + + ' Compute future dimensions of output array + Select Case iDims + Case 0 : lMin1 = lMin : lMax1 = lMax + lMin2 = 0 : lMax2 = -1 + Case 1 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = 0 : lMax2 = 0 + Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + End Select + If iDims > 0 And lMax - lMin <> lMax1 - lMin1 Then GoTo CatchColumn + ReDim vAppendColumn(lMin1 To lMax1, lMin2 To lMax2 + 1) + + ' Copy input array to output array + For i = lMin1 To lMax1 + For j = lMin2 To lMax2 + If iDims = 2 Then vAppendColumn(i, j) = Array_2D(i, j) Else vAppendColumn(i, j) = Array_2D(i) + Next j + Next i + ' Copy new Column + For i = lMin1 To lMax1 + vAppendColumn(i, lMax2 + 1) = Column(i) + Next i + +Finally: + AppendColumn = vAppendColumn() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchColumn: + SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR)) + GoTo Finally +End Function ' ScriptForge.SF_Array.AppendColumn + +REM ----------------------------------------------------------------------------- +Public Function AppendRow(Optional ByRef Array_2D As Variant _ + , Optional ByRef Row As Variant _ + ) As Variant +''' AppendRow appends below a 2D array a new row +''' Args +''' Array_2D: the pre-existing array, may be empty +''' If the array has 1 dimension, it is considered as the 1st row of the resulting 2D array +''' Row: a 1D array with as many items as there are columns in Array_2D +''' Returns: +''' the new extended array. Its LBounds are identical to that of Array_2D +''' Exceptions: +''' ARRAYINSERTERROR +''' Examples: +''' SF_Array.AppendRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((1, 2, 3), (4, 5, 6)) +''' x = SF_Array.AppendRow(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i + +Dim vAppendRow As Variant ' Return value +Dim iDims As Integer ' Dimensions of Array_2D +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim lMin As Long ' LBound of row array +Dim lMax As Long ' UBound of row array +Dim i As Long +Dim j As Long +Const cstThisSub = "Array.AppendRow" +Const cstSubArgs = "Array_2D, Row" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vAppendRow = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array + If Not SF_Utils._ValidateArray(Row, "Row", 1) Then GoTo Finally + End If + iDims = SF_Array.CountDims(Array_2D) + If iDims > 2 Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error + End If + +Try: + lMin = LBound(Row) + lMax = UBound(Row) + + ' Compute future dimensions of output array + Select Case iDims + Case 0 : lMin1 = 0 : lMax1 = -1 + lMin2 = lMin : lMax2 = lMax + Case 1 : lMin1 = 0 : lMax1 = 0 + lMin2 = LBound(Array_2D, 1) : lMax2 = UBound(Array_2D, 1) + Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + End Select + If iDims > 0 And lMax - lMin <> lMax2 - lMin2 Then GoTo CatchRow + ReDim vAppendRow(lMin1 To lMax1 + 1, lMin2 To lMax2) + + ' Copy input array to output array + For i = lMin1 To lMax1 + For j = lMin2 To lMax2 + If iDims = 2 Then vAppendRow(i, j) = Array_2D(i, j) Else vAppendRow(i, j) = Array_2D(j) + Next j + Next i + ' Copy new row + For j = lMin2 To lMax2 + vAppendRow(lMax1 + 1, j) = Row(j) + Next j + +Finally: + AppendRow = vAppendRow() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchRow: + SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR)) + GoTo Finally +End Function ' ScriptForge.SF_Array.AppendRow + +REM ----------------------------------------------------------------------------- +Public Function Contains(Optional ByRef Array_1D As Variant _ + , Optional ByVal ToFind As Variant _ + , Optional ByVal CaseSensitive As Variant _ + , Optional ByVal SortOrder As Variant _ + ) As Boolean +''' Check if a 1D array contains the ToFind number, string or date +''' The comparison between strings can be done case-sensitive or not +''' If the array is sorted then +''' the array must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' a binary search is done +''' Otherwise the array is scanned from top. Null or Empty items are simply ignored +''' Args: +''' Array_1D: the array to scan +''' ToFind: a number, a date or a string to find +''' CaseSensitive: Only for string comparisons, default = False +''' SortOrder: "ASC", "DESC" or "" (= not sorted, default) +''' Return: True when found +''' Result is unpredictable when array is announced sorted and is in reality not +''' Examples: +''' SF_Array.Contains(Array("A","B","c","D"), "C", SortOrder := "ASC") returns True +''' SF_Array.Contains(Array("A","B","c","D"), "C", CaseSensitive := True) returns False + +Dim bContains As Boolean ' Return value +Dim iToFindType As Integer ' VarType of ToFind +Const cstThisSub = "Array.Contains" +Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + bContains = False + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally + If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally + iToFindType = SF_Utils._VarTypeExt(ToFind) + If SortOrder <> "" Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, iToFindType) Then GoTo Finally + Else + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + bContains = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, SortOrder)(0) + +Finally: + Contains = bContains + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Contains + +REM ----------------------------------------------------------------------------- +Public Function ConvertToDictionary(Optional ByRef Array_2D As Variant) As Variant +''' Store the content of a 2-columns array into a dictionary +''' Key found in 1st column, Item found in 2nd +''' Args: +''' Array_2D: 1st column must contain exclusively non zero-length strings +''' 1st column may not be sorted +''' Returns: +''' a ScriptForge dictionary object +''' Examples: +''' + +Dim oDict As Variant ' Return value +Dim i As Long +Const cstThisSub = "Dictionary.ConvertToArray" +Const cstSubArgs = "Array_2D" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2, V_STRING, True) Then GoTo Finally + End If + +Try: + Set oDict = SF_Services.CreateScriptService("Dictionary") + For i = LBound(Array_2D, 1) To UBound(Array_2D, 1) + oDict.Add(Array_2D(i, 0), Array_2D(i, 1)) + Next i + + ConvertToDictionary = oDict + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.ConvertToDictionary + +REM ----------------------------------------------------------------------------- +Public Function Copy(Optional ByRef Array_ND As Variant) As Variant +''' Duplicate a 1D or 2D array +''' A usual assignment copies an array by reference, i.e. shares the same memory location +''' Dim a, b +''' a = Array(1, 2, 3) +''' b = a +''' a(2) = 30 +''' MsgBox b(2) ' 30 +''' Args +''' Array_ND: the array to copy, may be empty +''' Return: +''' the copied array. Subarrays however still remain assigned by reference +''' Examples: +''' SF_Array.Copy(Array(1, 2, 3)) returns (1, 2, 3) + +Dim vCopy As Variant ' Return value +Dim iDims As Integer ' Number of dimensions of the input array +Const cstThisSub = "Array.Copy" +Const cstSubArgs = "Array_ND" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vCopy = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_ND, "Array_ND") Then GoTo Finally + iDims = SF_Array.CountDims(Array_ND) + If iDims > 2 Then + If Not SF_Utils._ValidateArray(Array_ND, "Array_ND", 2) Then GoTo Finally + End If + End If + +Try: + Select Case iDims + Case 0 + Case 1 + vCopy = Array_ND + ReDim Preserve vCopy(LBound(Array_ND) To UBound(Array_ND)) + Case 2 + vCopy = Array_ND + ReDim Preserve vCopy(LBound(Array_ND, 1) To UBound(Array_ND, 1), LBound(Array_ND, 2) To UBound(Array_ND, 2)) + End Select + +Finally: + Copy = vCopy() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Copy + +REM ----------------------------------------------------------------------------- +Public Function CountDims(Optional ByRef Array_ND As Variant) As Integer +''' Count the number of dimensions of an array - may be > 2 +''' Args: +''' Array_ND: the array to be examined +''' Return: the number of dimensions: -1 = not array, 0 = uninitialized array, else >= 1 +''' Examples: +''' Dim a(1 To 10, -3 To 12, 5) +''' CountDims(a) returns 3 + +Dim iDims As Integer ' Return value +Dim lMax As Long ' Storage for UBound of each dimension +Const cstThisSub = "Array.CountDims" +Const cstSubArgs = "Array_ND" + +Check: + iDims = -1 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If IsMissing(Array_ND) Then ' To have missing exception processed + If Not SF_Utils._ValidateArray(Array_ND, "Array_ND") Then GoTo Finally + End If + End If + +Try: + On Local Error Goto ErrHandler + ' Loop, increasing the dimension index (i) until an error occurs. + ' An error will occur when i exceeds the number of dimensions in the array. Returns i - 1. + iDims = 0 + If Not IsArray(Array_ND) Then + Else + Do + iDims = iDims + 1 + lMax = UBound(Array_ND, iDims) + Loop Until (Err <> 0) + End If + + ErrHandler: + On Local Error GoTo 0 + + iDims = iDims - 1 + If iDims = 1 Then + If LBound(Array_ND, 1) > UBound(Array_ND, 1) Then iDims = 0 + End If + +Finally: + CountDims = iDims + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Array.CountDims + +REM ----------------------------------------------------------------------------- +Public Function Difference(Optional ByRef Array1_1D As Variant _ + , Optional ByRef Array2_1D As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Build a set being the Difference of the two input arrays, i.e. items are contained in 1st array and NOT in 2nd +''' both input arrays must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' The comparison between strings is case sensitive or not +''' Args: +''' Array1_1D: a 1st input array +''' Array2_1D: a 2nd input array +''' CaseSensitive: default = False +''' Returns: a zero-based array containing unique items from the 1st array not present in the 2nd +''' The output array is sorted in ascending order +''' Examples: +''' SF_Array.Difference(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B") + +Dim vDifference() As Variant ' Return value +Dim vSorted() As Variant ' The 2nd input array after sort +Dim iType As Integer ' VarType of elements in input arrays +Dim lMin1 As Long ' LBound of 1st input array +Dim lMax1 As Long ' UBound of 1st input array +Dim lMin2 As Long ' LBound of 2nd input array +Dim lMax2 As Long ' UBound of 2nd input array +Dim lSize As Long ' Number of Difference items +Dim vItem As Variant ' One single item in the array +Dim i As Long +Const cstThisSub = "Array.Difference" +Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vDifference = Array() + +Check: + If IsMissing(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array1_1D, "Array1_1D", 1, 0, True) Then GoTo Finally + iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D))) + If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D) + lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D) + + ' If 1st array is empty, do nothing + If lMax1 < lMin1 Then + ElseIf lMax2 < lMin2 Then ' only 2nd array is empty + vUnion = SF_Array.Unique(Array1_1D, CaseSensitive) + Else + + ' First sort the 2nd array + vSorted = SF_Array.Sort(Array2_1D, "ASC", CaseSensitive) + + ' Resize the output array to the size of the 1st array + ReDim vDifference(0 To (lMax1 - lMin1)) + lSize = -1 + + ' Fill vDifference one by one with items present only in 1st set + For i = lMin1 To lMax1 + vItem = Array1_1D(i) + If Not SF_Array.Contains(vSorted, vItem, CaseSensitive, "ASC") Then + lSize = lSize + 1 + vDifference(lSize) = vItem + End If + Next i + + ' Remove unfilled entries and duplicates + If lSize >= 0 Then + ReDim Preserve vDifference(0 To lSize) + vDifference() = SF_Array.Unique(vDifference, CaseSensitive) + Else + vDifference = Array() + End If + End If + +Finally: + Difference = vDifference() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Difference + +REM ----------------------------------------------------------------------------- +Public Function ExportToTextFile(Optional ByRef Array_1D As Variant _ + , Optional ByVal FileName As Variant _ + , Optional ByVal Encoding As Variant _ + ) As Boolean +''' Write all items of the array sequentially to a text file +''' If the file exists already, it will be overwritten without warning +''' Args: +''' Array_1D: the array to export +''' FileName: the full name (path + file) in SF_FileSystem.FileNaming notation +''' Encoding: The character set that should be used +''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Note that LibreOffice does not implement all existing sets +''' Default = UTF-8 +''' Returns: +''' True if successful +''' Examples: +''' SF_Array.ExportToTextFile(Array("A","B","C","D"), "C:\Temp\A short file.txt") + +Dim bExport As Boolean ' Return value +Dim oFile As Object ' Output file handler +Dim sLine As String ' A single line +Const cstThisSub = "Array.ExportToTextFile" +Const cstSubArgs = "Array_1D, FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bExport = False + +Check: + If IsMissing(Encoding) Or IsEmpty(Encoding) Then Encoding = "UTF-8" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, V_STRING, True) Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Encoding, "Encoding", V_STRING) Then GoTo Finally + End If + +Try: + Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True, Encoding := Encoding) + If Not IsNull(oFile) Then + With oFile + For Each sLine In Array_1D + .WriteLine(sLine) + Next sLine + .CloseFile() + End With + End If + + bExport = True + +Finally: + If Not IsNull(oFile) Then Set oFile = oFile.Dispose() + ExportToTextFile = bExport + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.ExportToTextFile + +REM ----------------------------------------------------------------------------- +Public Function ExtractColumn(Optional ByRef Array_2D As Variant _ + , Optional ByVal ColumnIndex As Variant _ + ) As Variant +''' ExtractColumn extracts from a 2D array a specific column +''' Args +''' Array_2D: the array from which to extract +''' ColumnIndex: the column to extract - must be in the interval [LBound, UBound] +''' Returns: +''' the extracted column. Its LBound and UBound are identical to that of the 1st dimension of Array_2D +''' Exceptions: +''' ARRAYINDEX1ERROR +''' Examples: +''' |1, 2, 3| +''' SF_Array.ExtractColumn( |4, 5, 6|, 2) returns (3, 6, 9) +''' |7, 8, 9| + +Dim vExtractColumn As Variant ' Return value +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound1 of input array +Dim lMax2 As Long ' UBound1 of input array +Dim i As Long +Const cstThisSub = "Array.ExtractColumn" +Const cstSubArgs = "Array_2D, ColumnIndex" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vExtractColumn = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally + If Not SF_Utils._Validate(ColumnIndex, "ColumnIndex", V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Compute future dimensions of output array + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + If ColumnIndex < lMin2 Or ColumnIndex > lMax2 Then GoTo CatchIndex + lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + ReDim vExtractColumn(lMin1 To lMax1) + + ' Copy Column of input array to output array + For i = lMin1 To lMax1 + vExtractColumn(i) = Array_2D(i, ColumnIndex) + Next i + +Finally: + ExtractColumn = vExtractColumn() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchIndex: + SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "ColumnIndex", SF_Array._Repr(Array_2D), ColumnIndex) + GoTo Finally +End Function ' ScriptForge.SF_Array.ExtractColumn + +REM ----------------------------------------------------------------------------- +Public Function ExtractRow(Optional ByRef Array_2D As Variant _ + , Optional ByVal RowIndex As Variant _ + ) As Variant +''' ExtractRow extracts from a 2D array a specific row +''' Args +''' Array_2D: the array from which to extract +''' RowIndex: the row to extract - must be in the interval [LBound, UBound] +''' Returns: +''' the extracted row. Its LBound and UBound are identical to that of the 2nd dimension of Array_2D +''' Exceptions: +''' ARRAYINDEX1ERROR +''' Examples: +''' |1, 2, 3| +''' SF_Array.ExtractRow(|4, 5, 6|, 2) returns (7, 8, 9) +''' |7, 8, 9| + +Dim vExtractRow As Variant ' Return value +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound1 of input array +Dim lMax2 As Long ' UBound1 of input array +Dim i As Long +Const cstThisSub = "Array.ExtractRow" +Const cstSubArgs = "Array_2D, RowIndex" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vExtractRow = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally + If Not SF_Utils._Validate(RowIndex, "RowIndex", V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Compute future dimensions of output array + lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + If RowIndex < lMin1 Or RowIndex > lMax1 Then GoTo CatchIndex + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + ReDim vExtractRow(lMin2 To lMax2) + + ' Copy row of input array to output array + For i = lMin2 To lMax2 + vExtractRow(i) = Array_2D(RowIndex, i) + Next i + +Finally: + ExtractRow = vExtractRow() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchIndex: + SF_Exception.RaiseFatal(ARRAYINDEX1ERROR, "RowIndex", SF_Array._Repr(Array_2D), RowIndex) + GoTo Finally +End Function ' ScriptForge.SF_Array.ExtractRow + +REM ----------------------------------------------------------------------------- +Public Function Flatten(Optional ByRef Array_1D As Variant) As Variant +''' Stack all items and all items in subarrays into one array without subarrays +''' Args +''' Array_1D: the pre-existing array, may be empty +''' Return: +''' The new flattened array. Its LBound is identical to that of Array_1D +''' If one of the subarrays has a number of dimensions > 1 Then that subarray is left unchanged +''' Examples: +''' SF_Array.Flatten(Array(1, 2, Array(3, 4, 5)) returns (1, 2, 3, 4, 5) + +Dim vFlatten As Variant ' Return value +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim lIndex As Long ' Index in output array +Dim vItem As Variant ' Array single item +Dim iDims As Integer ' Array number of dimensions +Dim lEmpty As Long ' Number of empty subarrays +Dim i As Long +Dim j As Long +Const cstThisSub = "Array.Flatten" +Const cstSubArgs = "Array_1D" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vFlatten = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + +Try: + If UBound(Array_1D) >= LBound(Array_1D) Then + lMin = LBound(Array_1D) : lMax = UBound(Array_1D) + ReDim vFlatten(lMin To lMax) ' Initial minimal sizing + lEmpty = 0 + lIndex = lMin - 1 + For i = lMin To lMax + vItem = Array_1D(i) + If IsArray(vItem) Then + iDims = SF_Array.CountDims(vItem) + Select Case iDims + Case 0 ' Empty arrays are ignored + lEmpty = lEmpty + 1 + Case 1 ' Only 1D subarrays are flattened + ReDim Preserve vFlatten(lMin To UBound(vFlatten) + UBound(vItem) - LBound(vItem)) + For j = LBound(vItem) To UBound(vItem) + lIndex = lIndex + 1 + vFlatten(lIndex) = vItem(j) + Next j + Case > 1 ' Other arrays are left unchanged + lIndex = lIndex + 1 + vFlatten(lIndex) = vItem + End Select + Else + lIndex = lIndex + 1 + vFlatten(lIndex) = vItem + End If + Next i + End If + ' Reduce size of output if Array_1D is populated with some empty arrays + If lEmpty > 0 Then + If lIndex - lEmpty < lMin Then + vFlatten = Array() + Else + ReDim Preserve vFlatten(lMin To UBound(vFlatten) - lEmpty) + End If + End If + +Finally: + Flatten = vFlatten() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Flatten + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Array.GetProperty" +Const cstSubArgs = "PropertyName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function ImportFromCSVFile(Optional ByRef FileName As Variant _ + , Optional ByVal Delimiter As Variant _ + , Optional ByVal DateFormat As Variant _ + , Optional ByVal _IsoDate As Variant _ + ) As Variant +''' Import the data contained in a comma-separated values (CSV) file +''' The comma may be replaced by any character +''' Each line in the file contains a full record +''' Line splitting is not allowed) +''' However sequences like \n, \t, ... are left unchanged. Use SF_String.Unescape() to manage them +''' A special mechanism is implemented to load dates +''' The applicable CSV format is described in https://tools.ietf.org/html/rfc4180 +''' Args: +''' FileName: the name of the text file containing the data expressed as given by the current FileNaming +''' property of the SF_FileSystem service. Default = both URL format or native format +''' Delimiter: Default = ",". Other usual options are ";" and the tab character +''' DateFormat: either YYYY-MM-DD, DD-MM-YYYY or MM-DD-YYYY +''' The dash (-) may be replaced by a dot (.), a slash (/) or a space +''' Other date formats will be ignored +''' If "" (default), dates will be considered as strings +''' _IsoDate: when True, the execution is initiated from Python, do not convert dates to Date variables. Internal use only +''' Returns: +''' A 2D-array with each row corresponding with a single record read in the file +''' and each column corresponding with a field of the record +''' No check is made about the coherence of the field types across columns +''' A best guess will be made to identify numeric and date types +''' If a line contains less or more fields than the first line in the file, +''' an exception will be raised. Empty lines however are simply ignored +''' If the size of the file exceeds the number of items limit, a warning is raised +''' and the array is truncated +''' Exceptions: +''' CSVPARSINGERROR Given file is not formatted as a csv file +''' CSVOVERFLOWWARNING Maximum number of allowed items exceeded + +Dim vArray As Variant ' Returned array +Dim lCol As Long ' Index of last column of vArray +Dim lRow As Long ' Index of current row of vArray +Dim lFileSize As Long ' Number of records found in the file +Dim vCsv As Object ' CSV file handler +Dim sLine As String ' Last read line +Dim vLine As Variant ' Array of fields of last read line +Dim sItem As String ' Individual item in the file +Dim vItem As Variant ' Individual item in the output array +Dim iPosition As Integer ' Date position in individual item +Dim iYear As Integer, iMonth As Integer, iDay As Integer + ' Date components +Dim i As Long +Const cstItemsLimit = 250000 ' Maximum number of admitted items +Const cstThisSub = "Array.ImportFromCSVFile" +Const cstSubArgs = "FileName, [Delimiter="",""], [DateFormat=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vArray = Array() + +Check: + If IsMissing(Delimiter) Or IsEmpty(Delimiter) Then Delimiter = "," + If IsMissing(DateFormat) Or IsEmpty(DateFormat) Then DateFormat = "" + If IsMissing(_IsoDate) Or IsEmpty(_IsoDate) Then _IsoDate = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Delimiter, "Delimiter", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(DateFormat, "DateFormat", V_STRING) Then GoTo Finally + End If + If Len(Delimiter) = 0 Then Delimiter = "," + +Try: + ' Counts the lines present in the file to size the final array + ' Very beneficial for large files, better than multiple ReDims + ' Small overhead for small files + lFileSize = SF_FileSystem._CountTextLines(FileName, False) + If lFileSize <= 0 Then GoTo Finally + + ' Reread file line by line + Set vCsv = SF_FileSystem.OpenTextFile(FileName, IOMode := SF_FileSystem.ForReading) + If IsNull(vCsv) Then GoTo Finally ' Open error + lRow = -1 + With vCsv + Do While Not .AtEndOfStream + sLine = .ReadLine() + If Len(sLine) > 0 Then ' Ignore empty lines + If InStr(sLine, """") > 0 Then vLine = SF_String.SplitNotQuoted(sLine, Delimiter) Else vLine = Split(sLine, Delimiter) ' Simple split when relevant + lRow = lRow + 1 + If lRow = 0 Then ' Initial sizing of output array + lCol = UBound(vLine) + ReDim vArray(0 To lFileSize - 1, 0 To lCol) + ElseIf UBound(vLine) <> lCol Then + GoTo CatchCSVFormat + End If + ' Check type and copy all items of the line + For i = 0 To lCol + If Left(vLine(i), 1) = """" Then sItem = SF_String.Unquote(vLine(i)) Else sItem = vLine(i) ' Unquote only when useful + ' Interpret the individual line item + Select Case True + Case IsNumeric(sItem) + If InStr(sItem, ".") + InStr(1, sItem, "e", 1) > 0 Then vItem = Val(sItem) Else vItem = CLng(sItem) + Case DateFormat <> "" And Len(sItem) = Len(DateFormat) + If SF_String.IsADate(sItem, DateFormat) Then + iPosition = InStr(DateFormat, "YYYY") : iYear = CInt(Mid(sItem, iPosition, 4)) + iPosition = InStr(DateFormat, "MM") : iMonth = CInt(Mid(sItem, iPosition, 2)) + iPosition = InStr(DateFormat, "DD") : iDay = CInt(Mid(sItem, iPosition, 2)) + vItem = DateSerial(iYear, iMonth, iDay) + If _IsoDate Then vItem = SF_Utils._CDateToIso(vItem) ' Called from Python + Else + vItem = sItem + End If + Case Else : vItem = sItem + End Select + vArray(lRow, i) = vItem + Next i + End If + ' Provision to avoid very large arrays and their sometimes erratic behaviour + If (lRow + 2) * (lCol + 1) > cstItemsLimit Then + ReDim Preserve vArray(0 To lRow, 0 To lCol) + GoTo CatchOverflow + End If + Loop + End With + +Finally: + If Not IsNull(vCsv) Then + vCsv.CloseFile() + Set vCsv = vCsv.Dispose() + End If + ImportFromCSVFile = vArray + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchCSVFormat: + SF_Exception.RaiseFatal(CSVPARSINGERROR, FileName, vCsv.Line, sLine) + GoTo Finally +CatchOverflow: + 'TODO SF_Exception.RaiseWarning(SF_Exception.CSVOVERFLOWWARNING, cstThisSub) + 'MsgBox "TOO MUCH LINES !!" + GoTo Finally +End Function ' ScriptForge.SF_Array.ImportFromCSVFile + +REM ----------------------------------------------------------------------------- +Public Function IndexOf(Optional ByRef Array_1D As Variant _ + , Optional ByVal ToFind As Variant _ + , Optional ByVal CaseSensitive As Variant _ + , Optional ByVal SortOrder As Variant _ + ) As Long +''' Finds in a 1D array the ToFind number, string or date +''' ToFind must exist within the array. +''' The comparison between strings can be done case-sensitively or not +''' If the array is sorted then +''' the array must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' a binary search is done +''' Otherwise the array is scanned from top. Null or Empty items are simply ignored +''' Args: +''' Array_1D: the array to scan +''' ToFind: a number, a date or a string to find +''' CaseSensitive: Only for string comparisons, default = False +''' SortOrder: "ASC", "DESC" or "" (= not sorted, default) +''' Return: the index of the found item, LBound - 1 if not found +''' Result is unpredictable when array is announced sorted and is in reality not +''' Examples: +''' SF_Array.IndexOf(Array("A","B","c","D"), "C", SortOrder := "ASC") returns 2 +''' SF_Array.IndexOf(Array("A","B","c","D"), "C", CaseSensitive := True) returns -1 + +Dim vFindItem As Variant ' 2-items array (0) = True if found, (1) = Index where found +Dim lIndex As Long ' Return value +Dim iToFindType As Integer ' VarType of ToFind +Const cstThisSub = "Array.IndexOf" +Const cstSubArgs = "Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""""|""ASC""|""DESC""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + lIndex = -1 + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC", "DESC", "")) Then GoTo Finally + If Not SF_Utils._Validate(ToFind, "ToFind", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally + iToFindType = SF_Utils._VarTypeExt(ToFind) + If SortOrder <> "" Then + If Not SF_Utils._ValidateArray(Array_1D, "Array", 1, iToFindType) Then GoTo Finally + Else + If Not SF_Utils._ValidateArray(Array_1D, "Array", 1) Then GoTo Finally + End If + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + vFindItem = SF_Array._FindItem(Array_1D, ToFind, CaseSensitive, SortOrder) + If vFindItem(0) = True Then lIndex = vFindItem(1) Else lIndex = LBound(Array_1D) - 1 + +Finally: + IndexOf = lIndex + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.IndexOf + +REM ----------------------------------------------------------------------------- +Public Function Insert(Optional ByRef Array_1D As Variant _ + , Optional ByVal Before As Variant _ + , ParamArray pvArgs() As Variant _ + ) As Variant +''' Insert before the index Before of the input array the items listed as arguments +''' Arguments are inserted blindly +''' each of them might be a scalar of any type or a subarray +''' Args +''' Array_1D: the pre-existing array, may be empty +''' Before: the index before which to insert; must be in the interval [LBound, UBound + 1] +''' pvArgs: a list of items to Insert inside Array_1D +''' Returns: +''' the new rxtended array. Its LBound is identical to that of Array_1D +''' Exceptions: +''' ARRAYINSERTERROR +''' Examples: +''' SF_Array.Insert(Array(1, 2, 3), 2, 4, 5) returns (1, 2, 4, 5, 3) + +Dim vInsert As Variant ' Return value +Dim lNbArgs As Long ' Number of elements to Insert +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim i As Long +Const cstThisSub = "Array.Insert" +Const cstSubArgs = "Array_1D, Before, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vInsert = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + If Not SF_Utils._Validate(Before, "Before", V_NUMERIC) Then GoTo Finally + If Before < LBound(Array_1D) Or Before > UBound(Array_1D) + 1 Then GoTo CatchArgument + End If + +Try: + lNbArgs = UBound(pvArgs) + 1 ' pvArgs is always zero-based + lMin = LBound(Array_1D) ' = LBound(vInsert) + lMax = UBound(Array_1D) ' <> UBound(vInsert) + If lNbArgs > 0 Then + ReDim vInsert(lMin To lMax + lNbArgs) + For i = lMin To UBound(vInsert) + If i < Before Then + vInsert(i) = Array_1D(i) + ElseIf i < Before + lNbArgs Then + vInsert(i) = pvArgs(i - Before) + Else + vInsert(i) = Array_1D(i - lNbArgs) + End If + Next i + Else + vInsert() = Array_1D() + End If + +Finally: + Insert = vInsert() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchArgument: + 'TODO SF_Exception.RaiseFatal(ARRAYINSERTERROR, cstThisSub) + MsgBox "INVALID ARGUMENT VALUE !!" + GoTo Finally +End Function ' ScriptForge.SF_Array.Insert + +REM ----------------------------------------------------------------------------- +Public Function InsertSorted(Optional ByRef Array_1D As Variant _ + , Optional ByVal Item As Variant _ + , Optional ByVal SortOrder As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Insert in a sorted array a new item on its place +''' the array must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' Args: +''' Array_1D: the array to sort +''' Item: the scalar value to insert, same type as the existing array items +''' SortOrder: "ASC" (default) or "DESC" +''' CaseSensitive: Default = False +''' Returns: the extended sorted array with same LBound as input array +''' Examples: +''' InsertSorted(Array("A", "C", "a", "b"), "B", CaseSensitive := True) returns ("A", "B", "C", "a", "b") + +Dim vSorted() As Variant ' Return value +Dim iType As Integer ' VarType of elements in input array +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim lIndex As Long ' Place where to insert new item +Const cstThisSub = "Array.InsertSorted" +Const cstSubArgs = "Array_1D, Item, [SortOrder=""ASC""|""DESC""], [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSorted = Array() + +Check: + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC" + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, 0) Then GoTo Finally + If LBound(Array_1D) <= UBound(Array_1D) Then + iType = SF_Utils._VarTypeExt(Array_1D(LBound(Array_1D))) + If Not SF_Utils._Validate(Item, "Item", iType) Then GoTo Finally + Else + If Not SF_Utils._Validate(Item, "Item", Array(V_STRING, V_DATE, V_NUMERIC)) Then GoTo Finally + End If + If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin = LBound(Array_1D) + lMax = UBound(Array_1D) + lIndex = SF_Array._FindItem(Array_1D, Item, CaseSensitive, SortOrder)(1) + vSorted = SF_Array.Insert(Array_1D, lIndex, Item) + +Finally: + InsertSorted = vSorted() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.InsertSorted + +REM ----------------------------------------------------------------------------- +Public Function Intersection(Optional ByRef Array1_1D As Variant _ + , Optional ByRef Array2_1D As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Build a set being the intersection of the two input arrays, i.e. items are contained in both arrays +''' both input arrays must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' The comparison between strings is case sensitive or not +''' Args: +''' Array1_1D: a 1st input array +''' Array2_1D: a 2nd input array +''' CaseSensitive: default = False +''' Returns: a zero-based array containing unique items stored in both input arrays +''' The output array is sorted in ascending order +''' Examples: +''' Intersection(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("C", "b") + +Dim vIntersection() As Variant ' Return value +Dim vSorted() As Variant ' The shortest input array after sort +Dim iType As Integer ' VarType of elements in input arrays +Dim lMin1 As Long ' LBound of 1st input array +Dim lMax1 As Long ' UBound of 1st input array +Dim lMin2 As Long ' LBound of 2nd input array +Dim lMax2 As Long ' UBound of 2nd input array +Dim lMin As Long ' LBound of unsorted array +Dim lMax As Long ' UBound of unsorted array +Dim iShortest As Integer ' 1 or 2 depending on shortest input array +Dim lSize As Long ' Number of Intersection items +Dim vItem As Variant ' One single item in the array +Dim i As Long +Const cstThisSub = "Array.Intersection" +Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vIntersection = Array() + +Check: + If IsMissing(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array1_1D, "Array1_1D", 1, 0, True) Then GoTo Finally + iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D))) + If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D) + lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D) + + ' If one of both arrays is empty, do nothing + If lMax1 >= lMin1 And lMax2 >= lMin2 Then + + ' First sort the shortest array + If lMax1 - lMin1 <= lMax2 - lMin2 Then + iShortest = 1 + vSorted = SF_Array.Sort(Array1_1D, "ASC", CaseSensitive) + lMin = lMin2 : lMax = lMax2 ' Bounds of unsorted array + Else + iShortest = 2 + vSorted = SF_Array.Sort(Array2_1D, "ASC", CaseSensitive) + lMin = lMin1 : lMax = lMax1 ' Bounds of unsorted array + End If + + ' Resize the output array to the size of the shortest array + ReDim vIntersection(0 To (lMax - lMin)) + lSize = -1 + + ' Fill vIntersection one by one only with items present in both sets + For i = lMin To lMax + If iShortest = 1 Then vItem = Array2_1D(i) Else vItem = Array1_1D(i) ' Pick in unsorted array + If SF_Array.Contains(vSorted, vItem, CaseSensitive, "ASC") Then + lSize = lSize + 1 + vIntersection(lSize) = vItem + End If + Next i + + ' Remove unfilled entries and duplicates + If lSize >= 0 Then + ReDim Preserve vIntersection(0 To lSize) + vIntersection() = SF_Array.Unique(vIntersection, CaseSensitive) + Else + vIntersection = Array() + End If + End If + +Finally: + Intersection = vIntersection() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Intersection + +REM ----------------------------------------------------------------------------- +Public Function Join2D(Optional ByRef Array_2D As Variant _ + , Optional ByVal ColumnDelimiter As Variant _ + , Optional ByVal RowDelimiter As Variant _ + , Optional ByVal Quote As Variant _ + ) As String +''' Join a two-dimensional array with two delimiters, one for columns, one for rows +''' Args: +''' Array_2D: each item must be either a String, a number, a Date or a Boolean +''' ColumnDelimiter: delimits each column (default = Tab/Chr(9)) +''' RowDelimiter: delimits each row (default = LineFeed/Chr(10)) +''' Quote: if True, protect strings with double quotes (default = False) +''' Return: +''' A string after conversion of numbers and dates +''' Invalid items are replaced by a zero-length string +''' Examples: +''' | 1, 2, "A", [2020-02-29], 5 | +''' SF_Array.Join_2D( | 6, 7, "this is a string", 9, 10 | , ",", "/") +''' ' "1,2,A,2020-02-29 00:00:00,5/6,7,this is a string,9,10" + +Dim sJoin As String ' The return value +Dim sItem As String ' The string representation of a single item +Dim vItem As Variant ' Single item +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim i As Long +Dim j As Long +Const cstThisSub = "Array.Join2D" +Const cstSubArgs = "Array_2D, [ColumnDelimiter=Chr(9)], [RowDelimiter=Chr(10)], [Quote=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sJoin = "" + +Check: + If IsMissing(ColumnDelimiter) Or IsEmpty(ColumnDelimiter) Then ColumnDelimiter = Chr(9) + If IsMissing(RowDelimiter) Or IsEmpty(RowDelimiter) Then RowDelimiter = Chr(10) + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally + If Not SF_Utils._Validate(ColumnDelimiter, "ColumnDelimiter", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(RowDelimiter, "RowDelimiter", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Quote, "Quote", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + If lMin1 <= lMax1 Then + For i = lMin1 To lMax1 + For j = lMin2 To lMax2 + vItem = Array_2D(i, j) + Select Case SF_Utils._VarTypeExt(vItem) + Case V_STRING : If Quote Then sItem = SF_String.Quote(vItem) Else sItem = vItem + Case V_NUMERIC, V_DATE : sItem = SF_Utils._Repr(vItem) + Case V_BOOLEAN : sItem = Iif(vItem, "True", "False") 'TODO: L10N + Case Else : sItem = "" + End Select + sJoin = sJoin & sItem & Iif(j < lMax2, ColumnDelimiter, "") + Next j + sJoin = sJoin & Iif(i < lMax1, RowDelimiter, "") + Next i + End If + +Finally: + Join2D = sJoin + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Join2D + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Array service as an array + + Methods = Array( _ + "Append" _ + , "AppendColumn" _ + , "AppendRow" _ + , "Contains" _ + , "ConvertToDictionary" _ + , "CountDims" _ + , "Difference" _ + , "ExportToTextFile" _ + , "ExtractColumn" _ + , "ExtractRow" _ + , "Flatten" _ + , "ImportFromCSVFile" _ + , "IndexOf" _ + , "Insert" _ + , "InsertSorted" _ + , "Intersection" _ + , "Join2D" _ + , "Prepend" _ + , "PrependColumn" _ + , "PrependRow" _ + , "RangeInit" _ + , "Reverse" _ + , "Shuffle" _ + , "Sort" _ + , "SortColumns" _ + , "SortRows" _ + , "Transpose" _ + , "TrimArray" _ + , "Union" _ + , "Unique" _ + ) + +End Function ' ScriptForge.SF_Array.Methods + +REM ----------------------------------------------------------------------------- +Public Function Prepend(Optional ByRef Array_1D As Variant _ + , ParamArray pvArgs() As Variant _ + ) As Variant +''' Prepend at the beginning of the input array the items listed as arguments +''' Arguments are Prepended blindly +''' each of them might be a scalar of any type or a subarray +''' Args +''' Array_1D: the pre-existing array, may be empty +''' pvArgs: a list of items to Prepend to Array_1D +''' Return: the new rxtended array. Its LBound is identical to that of Array_1D +''' Examples: +''' SF_Array.Prepend(Array(1, 2, 3), 4, 5) returns (4, 5, 1, 2, 3) + +Dim vPrepend As Variant ' Return value +Dim lNbArgs As Long ' Number of elements to Prepend +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim i As Long +Const cstThisSub = "Array.Prepend" +Const cstSubArgs = "Array_1D, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vPrepend = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + +Try: + lNbArgs = UBound(pvArgs) + 1 ' pvArgs is always zero-based + lMin = LBound(Array_1D) ' = LBound(vPrepend) + lMax = UBound(Array_1D) ' <> UBound(vPrepend) + If lMax < LBound(Array_1D) And lNbArgs > 0 Then ' Initial array is empty + ReDim vPrepend(0 To lNbArgs - 1) + Else + ReDim vPrepend(lMin To lMax + lNbArgs) + End If + For i = lMin To UBound(vPrepend) + If i < lMin + lNbArgs Then vPrepend(i) = pvArgs(i - lMin) Else vPrepend(i) = Array_1D(i - lNbArgs) + Next i + +Finally: + Prepend = vPrepend + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Prepend + +REM ----------------------------------------------------------------------------- +Public Function PrependColumn(Optional ByRef Array_2D As Variant _ + , Optional ByRef Column As Variant _ + ) As Variant +''' PrependColumn prepends to the left side of a 2D array a new Column +''' Args +''' Array_2D: the pre-existing array, may be empty +''' If the array has 1 dimension, it is considered as the last Column of the resulting 2D array +''' Column: a 1D array with as many items as there are rows in Array_2D +''' Returns: +''' the new rxtended array. Its LBounds are identical to that of Array_2D +''' Exceptions: +''' ARRAYINSERTERROR +''' Examples: +''' SF_Array.PrependColumn(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 1), (5, 2), (6, 3)) +''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3)) => ∀ i ∈ {0 ≤ i ≤ 2} : x(0, i) ≡ i + +Dim vPrependColumn As Variant ' Return value +Dim iDims As Integer ' Dimensions of Array_2D +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim lMin As Long ' LBound of Column array +Dim lMax As Long ' UBound of Column array +Dim i As Long +Dim j As Long +Const cstThisSub = "Array.PrependColumn" +Const cstSubArgs = "Array_2D, Column" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vPrependColumn = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array + If Not SF_Utils._ValidateArray(Column, "Column", 1) Then GoTo Finally + End If + iDims = SF_Array.CountDims(Array_2D) + If iDims > 2 Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error + End If + +Try: + lMin = LBound(Column) + lMax = UBound(Column) + + ' Compute future dimensions of output array + Select Case iDims + Case 0 : lMin1 = lMin : lMax1 = lMax + lMin2 = 0 : lMax2 = -1 + Case 1 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = 0 : lMax2 = 0 + Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + End Select + If iDims > 0 And lMax - lMin <> lMax1 - lMin1 Then GoTo CatchColumn + ReDim vPrependColumn(lMin1 To lMax1, lMin2 To lMax2 + 1) + + ' Copy input array to output array + For i = lMin1 To lMax1 + For j = lMin2 + 1 To lMax2 + 1 + If iDims = 2 Then vPrependColumn(i, j) = Array_2D(i, j - 1) Else vPrependColumn(i, j) = Array_2D(i) + Next j + Next i + ' Copy new Column + For i = lMin1 To lMax1 + vPrependColumn(i, lMin2) = Column(i) + Next i + +Finally: + PrependColumn = vPrependColumn() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchColumn: + SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Column", SF_Array._Repr(Array_2D), SF_Utils._Repr(Column, MAXREPR)) + GoTo Finally +End Function ' ScriptForge.SF_Array.PrependColumn + +REM ----------------------------------------------------------------------------- +Public Function PrependRow(Optional ByRef Array_2D As Variant _ + , Optional ByRef Row As Variant _ + ) As Variant +''' PrependRow prepends on top of a 2D array a new row +''' Args +''' Array_2D: the pre-existing array, may be empty +''' If the array has 1 dimension, it is considered as the last row of the resulting 2D array +''' Row: a 1D array with as many items as there are columns in Array_2D +''' Returns: +''' the new rxtended array. Its LBounds are identical to that of Array_2D +''' Exceptions: +''' ARRAYINSERTERROR +''' Examples: +''' SF_Array.PrependRow(Array(1, 2, 3), Array(4, 5, 6)) returns ((4, 5, 6), (1, 2, 3)) +''' x = SF_Array.PrependColumn(Array(), Array(1, 2, 3) => ∀ i ∈ {0 ≤ i ≤ 2} : x(i, 0) ≡ i + +Dim vPrependRow As Variant ' Return value +Dim iDims As Integer ' Dimensions of Array_2D +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim lMin As Long ' LBound of row array +Dim lMax As Long ' UBound of row array +Dim i As Long +Dim j As Long +Const cstThisSub = "Array.PrependRow" +Const cstSubArgs = "Array_2D, Row" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vPrependRow = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D") Then GoTo Finally 'Initial check: not missing and array + If Not SF_Utils._ValidateArray(Row, "Row", 1) Then GoTo Finally + End If + iDims = SF_Array.CountDims(Array_2D) + If iDims > 2 Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally '2nd check to manage error + End If + +Try: + lMin = LBound(Row) + lMax = UBound(Row) + + ' Compute future dimensions of output array + Select Case iDims + Case 0 : lMin1 = 0 : lMax1 = -1 + lMin2 = lMin : lMax2 = lMax + Case 1 : lMin1 = 0 : lMax1 = 0 + lMin2 = LBound(Array_2D, 1) : lMax2 = UBound(Array_2D, 1) + Case 2 : lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + End Select + If iDims > 0 And lMax - lMin <> lMax2 - lMin2 Then GoTo CatchRow + ReDim vPrependRow(lMin1 To lMax1 + 1, lMin2 To lMax2) + + ' Copy input array to output array + For i = lMin1 + 1 To lMax1 + 1 + For j = lMin2 To lMax2 + If iDims = 2 Then vPrependRow(i, j) = Array_2D(i - 1, j) Else vPrependRow(i, j) = Array_2D(j) + Next j + Next i + ' Copy new row + For j = lMin2 To lMax2 + vPrependRow(lMin1, j) = Row(j) + Next j + +Finally: + PrependRow = vPrependRow() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchRow: + SF_Exception.RaiseFatal(ARRAYINSERTERROR, "Row", SF_Array._Repr(Array_2D), SF_Utils._Repr(Row, MAXREPR)) + GoTo Finally +End Function ' ScriptForge.SF_Array.PrependRow + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties as an array + + Properties = Array( _ + ) + +End Function ' ScriptForge.SF_Array.Properties + +REM ----------------------------------------------------------------------------- +Public Function RangeInit(Optional ByVal From As Variant _ + , Optional ByVal UpTo As Variant _ + , Optional ByVal ByStep As Variant _ + ) As Variant +''' Initialize a new zero-based array with numeric values +''' Args: all numeric +''' From: value of first item +''' UpTo: last item should not exceed UpTo +''' ByStep: difference between 2 successive items +''' Return: the new array +''' Exceptions: +''' ARRAYSEQUENCEERROR Wrong arguments, f.i. UpTo < From with ByStep > 0 +''' Examples: +''' SF_Array.RangeInit(10, 1, -1) returns (10, 9, 8, 7, 6, 5, 4, 3, 2, 1) + +Dim lIndex As Long ' Index of array +Dim lSize As Long ' UBound of resulting array +Dim vCurrentItem As Variant ' Last stored item +Dim vArray() ' The return value +Const cstThisSub = "Array.RangeInit" +Const cstSubArgs = "From, UpTo, [ByStep = 1]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vArray = Array() + +Check: + If IsMissing(ByStep) Or IsEmpty(ByStep) Then ByStep = 1 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(From, "From", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(UpTo, "UpTo", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(ByStep, "ByStep", V_NUMERIC) Then GoTo Finally + End If + If (From < UpTo And ByStep <= 0) Or (From > UpTo And ByStep >= 0) Then GoTo CatchSequence + +Try: + lSize = CLng(Abs((UpTo - From) / ByStep)) + ReDim vArray(0 To lSize) + For lIndex = 0 To lSize + vArray(lIndex) = From + lIndex * ByStep + Next lIndex + +Finally: + RangeInit = vArray + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchSequence: + SF_Exception.RaiseFatal(ARRAYSEQUENCEERROR, From, UpTo, ByStep) + GoTo Finally +End Function ' ScriptForge.SF_Array.RangeInit + +REM ----------------------------------------------------------------------------- +Public Function Reverse(Optional ByRef Array_1D As Variant) As Variant +''' Return the reversed 1D input array +''' Args: +''' Array_1D: the array to reverse +''' Returns: the reversed array +''' Examples: +''' SF_Array.Reverse(Array(1, 2, 3, 4)) returns (4, 3, 2, 1) + +Dim vReverse() As Variant ' Return value +Dim lHalf As Long ' Middle of array +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim i As Long, j As Long +Const cstThisSub = "Array.Reverse" +Const cstSubArgs = "Array_1D" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vReverse = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + +Try: + lMin = LBound(Array_1D) + lMax = UBound(Array_1D) + ReDim vReverse(lMin To lMax) + lHalf = Int((lMax + lMin) / 2) + j = lMax + For i = lMin To lHalf + vReverse(i) = Array_1D(j) + vReverse(j) = Array_1D(i) + j = j - 1 + Next i + ' Odd number of items + If IsEmpty(vReverse(lHalf + 1)) Then vReverse(lHalf + 1) = Array_1D(lHalf + 1) + +Finally: + Reverse = vReverse() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Reverse + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Array.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Shuffle(Optional ByRef Array_1D As Variant) As Variant +''' Returns a random permutation of a 1D array +''' https://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle +''' Args: +''' Array_1D: the array to shuffle +''' Returns: the shuffled array + +Dim vShuffle() As Variant ' Return value +Dim vSwapValue As Variant ' Intermediate value during swap +Dim lMin As Long ' LBound of Array_1D +Dim lCurrentIndex As Long ' Decremented from UBount to LBound +Dim lRandomIndex As Long ' Random between LBound and lCurrentIndex +Dim i As Long +Const cstThisSub = "Array.Shuffle" +Const cstSubArgs = "Array_1D" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vShuffle = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + +Try: + lMin = LBound(Array_1D) + lCurrentIndex = UBound(array_1D) + ' Initialize the output array + ReDim vShuffle(lMin To lCurrentIndex) + For i = lMin To lCurrentIndex + vShuffle(i) = Array_1D(i) + Next i + ' Now ... shuffle ! + Do While lCurrentIndex > lMin + lRandomIndex = Int(Rnd * (lCurrentIndex - lMin)) + lMin + vSwapValue = vShuffle(lCurrentIndex) + vShuffle(lCurrentIndex) = vShuffle(lRandomIndex) + vShuffle(lRandomIndex) = vSwapValue + lCurrentIndex = lCurrentIndex - 1 + Loop + +Finally: + Shuffle = vShuffle() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Shuffle + +REM ----------------------------------------------------------------------------- +Public Function Slice(Optional ByRef Array_1D As Variant _ + , Optional ByVal From As Variant _ + , Optional ByVal UpTo As Variant _ + ) As Variant +''' Returns a subset of a 1D array +''' Args: +''' Array_1D: the array to slice +''' From: the lower index of the subarray to extract (included) +''' UpTo: the upper index of the subarray to extract (included). Default = the last item of Array_1D +''' Returns: +''' The selected subarray with the same LBound as the input array. +''' If UpTo < From then the returned array is empty +''' Exceptions: +''' ARRAYINDEX2ERROR Wrong values for From and/or UpTo +''' Example: +''' SF_Array.Slice(Array(1, 2, 3, 4, 5), 1, 3) returns (2, 3, 4) + +Dim vSlice() As Variant ' Return value +Dim lMin As Long ' LBound of Array_1D +Dim lIndex As Long ' Current index in output array +Dim i As Long +Const cstThisSub = "Array.Slice" +Const cstSubArgs = "Array_1D, From, [UpTo = UBound(Array_1D)]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSlice = Array() + +Check: + If IsMissing(UpTo) Or IsEmpty(UpTo) Then UpTo = -1 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + If Not SF_Utils._Validate(From, "From", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(UpTo, "UpTo", V_NUMERIC) Then GoTo Finally + End If + If UpTo = -1 Then UpTo = UBound(Array_1D) + If From < LBound(Array_1D) Or From > UBound(Array_1D) _ + Or From > UpTo Or UpTo > UBound(Array_1D) Then GoTo CatchIndex + +Try: + If UpTo >= From Then + lMin = LBound(Array_1D) + ' Initialize the output array + ReDim vSlice(lMin To lMin + UpTo - From) + lIndex = lMin - 1 + For i = From To UpTo + lIndex = lIndex + 1 + vSlice(lIndex) = Array_1D(i) + Next i + End If + +Finally: + Slice = vSlice() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchIndex: + SF_Exception.RaiseFatal(ARRAYINDEX2ERROR, SF_Array._Repr(Array_1D), From, UpTo) + GoTo Finally +End Function ' ScriptForge.SF_Array.Slice + +REM ----------------------------------------------------------------------------- +Public Function Sort(Optional ByRef Array_1D As Variant _ + , Optional ByVal SortOrder As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Sort a 1D array in ascending or descending order. String comparisons can be case-sensitive or not +''' Args: +''' Array_1D: the array to sort +''' must be filled homogeneously by either strings, dates or numbers +''' Null and Empty values are allowed +''' SortOrder: "ASC" (default) or "DESC" +''' CaseSensitive: Default = False +''' Returns: the sorted array +''' Examples: +''' Sort(Array("a", "A", "b", "B", "C"), CaseSensitive := True) returns ("A", "B", "C", "a", "b") + +Dim vSort() As Variant ' Return value +Dim vIndexes() As Variant ' Indexes of sorted items +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim i As Long +Const cstThisSub = "Array.Sort" +Const cstSubArgs = "Array_1D, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSort = Array() + +Check: + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC" + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, 0) Then GoTo Finally + If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin = LBound(Array_1D) + lMax = UBound(Array_1D) + vIndexes() = SF_Array._HeapSort(Array_1D, ( SortOrder = "ASC" ), CaseSensitive) + + ' Load output array + ReDim vSort(lMin To lMax) + For i = lMin To lMax + vSort(i) = Array_1D(vIndexes(i)) + Next i + +Finally: + Sort = vSort() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Sort + +REM ----------------------------------------------------------------------------- +Public Function SortColumns(Optional ByRef Array_2D As Variant _ + , Optional ByVal RowIndex As Variant _ + , Optional ByVal SortOrder As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Returns a permutation of the columns of a 2D array, sorted on the values of a given row +''' Args: +''' Array_2D: the input array +''' RowIndex: the index of the row to sort the columns on +''' the row must be filled homogeneously by either strings, dates or numbers +''' Null and Empty values are allowed +''' SortOrder: "ASC" (default) or "DESC" +''' CaseSensitive: Default = False +''' Returns: +''' the array with permuted columns, LBounds and UBounds are unchanged +''' Exceptions: +''' ARRAYINDEXERROR +''' Examples: +''' | 5, 7, 3 | | 7, 5, 3 | +''' SF_Array.SortColumns( | 1, 9, 5 |, 2, "ASC") returns | 9, 1, 5 | +''' | 6, 1, 8 | | 1, 6, 8 | + +Dim vSort() As Variant ' Return value +Dim vRow() As Variant ' The row on which to sort the array +Dim vIndexes() As Variant ' Indexes of sorted row +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim i As Long, j As Long +Const cstThisSub = "Array.SortColumn" +Const cstSubArgs = "Array_2D, RowIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSort = Array() + +Check: + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC" + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally + If Not SF_Utils._Validate(RowIndex, "RowIndex", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + If RowIndex < lMin1 Or RowIndex > lMax1 Then GoTo CatchIndex + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + + ' Extract and sort the RowIndex-th row + vRow = SF_Array.ExtractRow(Array_2D, RowIndex) + If Not SF_Utils._ValidateArray(vRow, "Row #" & CStr(RowIndex), 1, 0) Then GoTo Finally + vIndexes() = SF_Array._HeapSort(vRow, ( SortOrder = "ASC" ), CaseSensitive) + + ' Load output array + ReDim vSort(lMin1 To lMax1, lMin2 To lMax2) + For i = lMin1 To lMax1 + For j = lMin2 To lMax2 + vSort(i, j) = Array_2D(i, vIndexes(j)) + Next j + Next i + +Finally: + SortColumns = vSort() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchIndex: + 'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub) + MsgBox "INVALID INDEX VALUE !!" + GoTo Finally +End Function ' ScriptForge.SF_Array.SortColumns + +REM ----------------------------------------------------------------------------- +Public Function SortRows(Optional ByRef Array_2D As Variant _ + , Optional ByVal ColumnIndex As Variant _ + , Optional ByVal SortOrder As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Returns a permutation of the rows of a 2D array, sorted on the values of a given column +''' Args: +''' Array_2D: the input array +''' ColumnIndex: the index of the column to sort the rows on +''' the column must be filled homogeneously by either strings, dates or numbers +''' Null and Empty values are allowed +''' SortOrder: "ASC" (default) or "DESC" +''' CaseSensitive: Default = False +''' Returns: +''' the array with permuted Rows, LBounds and UBounds are unchanged +''' Exceptions: +''' ARRAYINDEXERROR +''' Examples: +''' | 5, 7, 3 | | 1, 9, 5 | +''' SF_Array.SortRows( | 1, 9, 5 |, 0, "ASC") returns | 5, 7, 3 | +''' | 6, 1, 8 | | 6, 1, 8 | + +Dim vSort() As Variant ' Return value +Dim vCol() As Variant ' The column on which to sort the array +Dim vIndexes() As Variant ' Indexes of sorted row +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim i As Long, j As Long +Const cstThisSub = "Array.SortRow" +Const cstSubArgs = "Array_2D, ColumnIndex, [SortOrder=""""|""ASC""|""DESC""], [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSort = Array() + +Check: + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = "ASC" + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally + If Not SF_Utils._Validate(ColumnIndex, "ColumnIndex", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(SortOrder, "SortOrder", V_STRING, Array("ASC","DESC")) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + If ColumnIndex < lMin2 Or ColumnIndex > lMax2 Then GoTo CatchIndex + lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + + ' Extract and sort the ColumnIndex-th column + vCol = SF_Array.ExtractColumn(Array_2D, ColumnIndex) + If Not SF_Utils._ValidateArray(vCol, "Column #" & CStr(ColumnIndex), 1, 0) Then GoTo Finally + vIndexes() = SF_Array._HeapSort(vCol, ( SortOrder = "ASC" ), CaseSensitive) + + ' Load output array + ReDim vSort(lMin1 To lMax1, lMin2 To lMax2) + For i = lMin1 To lMax1 + For j = lMin2 To lMax2 + vSort(i, j) = Array_2D(vIndexes(i), j) + Next j + Next i + +Finally: + SortRows = vSort() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchIndex: + 'TODO SF_Exception.RaiseFatal(ARRAYINDEXERROR, cstThisSub) + MsgBox "INVALID INDEX VALUE !!" + GoTo Finally +End Function ' ScriptForge.SF_Array.SortRows + +REM ----------------------------------------------------------------------------- +Public Function Transpose(Optional ByRef Array_2D As Variant) As Variant +''' Swaps rows and columns in a 2D array +''' Args: +''' Array_2D: the array to transpose +''' Returns: +''' The transposed array +''' Examples: +''' | 1, 2 | | 1, 3, 5 | +''' SF_Array.Transpose( | 3, 4 | ) returns | 2, 4, 6 | +''' | 5, 6 | + +Dim vTranspose As Variant ' Return value +Dim lIndex As Long ' vTranspose index +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim i As Long, j As Long +Const cstThisSub = "Array.Transpose" +Const cstSubArgs = "Array_2D" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vTranspose = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_2D, "Array_2D", 2) Then GoTo Finally + End If + +Try: + ' Resize the output array + lMin1 = LBound(Array_2D, 1) : lMax1 = UBound(Array_2D, 1) + lMin2 = LBound(Array_2D, 2) : lMax2 = UBound(Array_2D, 2) + If lMin1 <= lMax1 Then + ReDim vTranspose(lMin2 To lMax2, lMin1 To lMax1) + End If + + ' Transpose items + For i = lMin1 To lMax1 + For j = lMin2 To lMax2 + vTranspose(j, i) = Array_2D(i, j) + Next j + Next i + +Finally: + Transpose = vTranspose + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Transpose + +REM ----------------------------------------------------------------------------- +Public Function TrimArray(Optional ByRef Array_1D As Variant) As Variant +''' Remove from a 1D array all Null, Empty and zero-length entries +''' Strings are trimmed as well +''' Args: +''' Array_1D: the array to scan +''' Return: The trimmed array +''' Examples: +''' SF_Array.TrimArray(Array("A","B",Null," D ")) returns ("A","B","D") + +Dim vTrimArray As Variant ' Return value +Dim lIndex As Long ' vTrimArray index +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim vItem As Variant ' Single array item +Dim i As Long +Const cstThisSub = "Array.TrimArray" +Const cstSubArgs = "Array_1D" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vTrimArray = Array() + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1) Then GoTo Finally + End If + +Try: + lMin = LBound(Array_1D) + lMax = UBound(Array_1D) + If lMin <= lMax Then + ReDim vTrimArray(lMin To lMax) + End If + lIndex = lMin - 1 + + ' Load only valid items from Array_1D to vTrimArray + For i = lMin To lMax + vItem = Array_1D(i) + Select Case VarType(vItem) + Case V_EMPTY + Case V_NULL : vItem = Empty + Case V_STRING + vItem = Trim(vItem) + If Len(vItem) = 0 Then vItem = Empty + Case Else + End Select + If Not IsEmpty(vItem) Then + lIndex = lIndex + 1 + vTrimArray(lIndex) = vItem + End If + Next i + + 'Keep valid entries + If lMin <= lIndex Then + ReDim Preserve vTrimArray(lMin To lIndex) + Else + vTrimArray = Array() + End If + +Finally: + TrimArray = vTrimArray + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.TrimArray + +REM ----------------------------------------------------------------------------- +Public Function Union(Optional ByRef Array1_1D As Variant _ + , Optional ByRef Array2_1D As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Build a set being the Union of the two input arrays, i.e. items are contained in any of both arrays +''' both input arrays must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' The comparison between strings is case sensitive or not +''' Args: +''' Array1_1D: a 1st input array +''' Array2_1D: a 2nd input array +''' CaseSensitive: default = False +''' Returns: a zero-based array containing unique items stored in any of both input arrays +''' The output array is sorted in ascending order +''' Examples: +''' SF_Array.Union(Array("A", "C", "A", "b", "B"), Array("C", "Z", "b"), True) returns ("A", "B", "C", "Z", "b") + +Dim vUnion() As Variant ' Return value +Dim iType As Integer ' VarType of elements in input arrays +Dim lMin1 As Long ' LBound of 1st input array +Dim lMax1 As Long ' UBound of 1st input array +Dim lMin2 As Long ' LBound of 2nd input array +Dim lMax2 As Long ' UBound of 2nd input array +Dim lSize As Long ' Number of Union items +Dim i As Long +Const cstThisSub = "Array.Union" +Const cstSubArgs = "Array1_1D, Array2_1D, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vUnion = Array() + +Check: + If IsMissing(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array1_1D, "Array1_1D", 1, 0, True) Then GoTo Finally + iType = SF_Utils._VarTypeExt(Array1_1D(LBound(Array1_1D))) + If Not SF_Utils._ValidateArray(Array2_1D, "Array2_1D", 1, iType, True) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin1 = LBound(Array1_1D) : lMax1 = UBound(Array1_1D) + lMin2 = LBound(Array2_1D) : lMax2 = UBound(Array2_1D) + + ' If both arrays are empty, do nothing + If lMax1 < lMin1 And lMax2 < lMin2 Then + ElseIf lMax1 < lMin1 Then ' only 1st array is empty + vUnion = SF_Array.Unique(Array2_1D, CaseSensitive) + ElseIf lMax2 < lMin2 Then ' only 2nd array is empty + vUnion = SF_Array.Unique(Array1_1D, CaseSensitive) + Else + + ' Build union of both arrays + ReDim vUnion(0 To (lMax1 - lMin1) + (lMax2 - lMin2) + 1) + lSize = -1 + + ' Fill vUnion one by one only with items present in any set + For i = lMin1 To lMax1 + lSize = lSize + 1 + vUnion(lSize) = Array1_1D(i) + Next i + For i = lMin2 To lMax2 + lSize = lSize + 1 + vUnion(lSize) = Array2_1D(i) + Next i + + ' Remove duplicates + vUnion() = SF_Array.Unique(vUnion, CaseSensitive) + End If + +Finally: + Union = vUnion() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Union + +REM ----------------------------------------------------------------------------- +Public Function Unique(Optional ByRef Array_1D As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Variant +''' Build a set of unique values derived from the input array +''' the input array must be filled homogeneously, i.e. all items must be of the same type +''' Empty and Null items are forbidden +''' The comparison between strings is case sensitive or not +''' Args: +''' Array_1D: the input array with potential duplicates +''' CaseSensitive: default = False +''' Returns: the array without duplicates with same LBound as input array +''' The output array is sorted in ascending order +''' Examples: +''' Unique(Array("A", "C", "A", "b", "B"), True) returns ("A", "B", "C", "b") + +Dim vUnique() As Variant ' Return value +Dim vSorted() As Variant ' The input array after sort +Dim lMin As Long ' LBound of input array +Dim lMax As Long ' UBound of input array +Dim lUnique As Long ' Number of unique items +Dim vIndex As Variant ' Output of _FindItem() method +Dim vItem As Variant ' One single item in the array +Dim i As Long +Const cstThisSub = "Array.Unique" +Const cstSubArgs = "Array_1D, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vUnique = Array() + +Check: + If IsMissing(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateArray(Array_1D, "Array_1D", 1, 0, True) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lMin = LBound(Array_1D) + lMax = UBound(Array_1D) + If lMax >= lMin Then + ' First sort the array + vSorted = SF_Array.Sort(Array_1D, "ASC", CaseSensitive) + ReDim vUnique(lMin To lMax) + lUnique = lMin + ' Fill vUnique one by one ignoring duplicates + For i = lMin To lMax + vItem = vSorted(i) + If i = lMin Then + vUnique(i) = vItem + Else + If SF_Array._ValCompare(vItem, vSorted(i - 1), CaseSensitive) = 0 Then ' Ignore item + Else + lUnique = lUnique + 1 + vUnique(lUnique) = vItem + End If + End If + Next i + ' Remove unfilled entries + ReDim Preserve vUnique(lMin To lUnique) + End If + +Finally: + Unique = vUnique() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Array.Unique + +REM ============================================================= PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Public Function _FindItem(ByRef pvArray_1D As Variant _ + , ByVal pvToFind As Variant _ + , ByVal pbCaseSensitive As Boolean _ + , ByVal psSortOrder As String _ + ) As Variant +''' Check if a 1D array contains the ToFind number, string or date and return its index +''' The comparison between strings can be done case-sensitively or not +''' If the array is sorted then a binary search is done +''' Otherwise the array is scanned from top. Null or Empty items are simply ignored +''' Args: +''' pvArray_1D: the array to scan +''' pvToFind: a number, a date or a string to find +''' pbCaseSensitive: Only for string comparisons, default = False +''' psSortOrder: "ASC", "DESC" or "" (= not sorted, default) +''' Return: a (0:1) array +''' (0) = True when found +''' (1) = if found: index of item +''' if not found: if sorted, index of next item in the array (might be = UBound + 1) +''' if not sorted, meaningless +''' Result is unpredictable when array is announced sorted and is in reality not +''' Called by Contains, IndexOf and InsertSorted. Also called by SF_Dictionary + +Dim bContains As Boolean ' True if match found +Dim iToFindType As Integer ' VarType of pvToFind +Dim lTop As Long, lBottom As Long ' Interval in scope of binary search +Dim lIndex As Long ' Index used in search +Dim iCompare As Integer ' Output of _ValCompare function +Dim lLoops As Long ' Count binary searches +Dim lMaxLoops As Long ' Max number of loops during binary search: to avoid infinite loops if array not sorted +Dim vFound(1) As Variant ' Returned array (Contains, Index) + + bContains = False + + If LBound(pvArray_1D) > UBound(pvArray_1D) Then ' Empty array, do nothing + Else + ' Search sequentially + If Len(psSortOrder) = 0 Then + For lIndex = LBound(pvArray_1D) To UBound(pvArray_1D) + bContains = ( SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive) = 0 ) + If bContains Then Exit For + Next lIndex + Else + ' Binary search + If psSortOrder = "ASC" Then + lTop = UBound(pvArray_1D) + lBottom = lBound(pvArray_1D) + Else + lBottom = UBound(pvArray_1D) + lTop = lBound(pvArray_1D) + End If + lLoops = 0 + lMaxLoops = CLng((Log(UBound(pvArray_1D) - LBound(pvArray_1D) + 1.0) / Log(2.0))) + 1 + Do + lLoops = lLoops + 1 + lIndex = (lTop + lBottom) / 2 + iCompare = SF_Array._ValCompare(pvToFind, pvArray_1D(lIndex), pbCaseSensitive) + Select Case True + Case iCompare = 0 : bContains = True + Case iCompare < 0 And psSortOrder = "ASC" + lTop = lIndex - 1 + Case iCompare > 0 And psSortOrder = "DESC" + lBottom = lIndex - 1 + Case iCompare > 0 And psSortOrder = "ASC" + lBottom = lIndex + 1 + Case iCompare < 0 And psSortOrder = "DESC" + lTop = lIndex + 1 + End Select + Loop Until ( bContains ) Or ( lBottom > lTop And psSortOrder = "ASC" ) Or (lBottom < lTop And psSortOrder = "DESC" ) Or lLoops > lMaxLoops + ' Flag first next non-matching element + If Not bContains Then lIndex = Iif(psSortOrder = "ASC", lBottom, lTop) + End If + End If + + ' Build output array + vFound(0) = bContains + vFound(1) = lIndex + _FindItem = vFound + +End Function ' ScriptForge.SF_Array._FindItem + +REM ----------------------------------------------------------------------------- +Private Function _HeapSort(ByRef pvArray As Variant _ + , Optional ByVal pbAscending As Boolean _ + , Optional ByVal pbCaseSensitive As Boolean _ + ) As Variant +''' Sort an array: items are presumed all strings, all dates or all numeric +''' Null or Empty are allowed and are considered smaller than other items +''' https://en.wikipedia.org/wiki/Heapsort +''' http://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-(sort-array-sorting-arrays)&p=2909250#post2909250 +''' HeapSort preferred to QuickSort because not recursive (this routine returns an array of indexes !!) +''' Args: +''' pvArray: a 1D array +''' pbAscending: default = True +''' pbCaseSensitive: default = False +''' Returns +''' An array of Longs of same dimensions as the input array listing the indexes of the sorted items +''' An empty array if the sort failed +''' Examples: +''' _HeapSort(Array(4, 2, 6, 1) returns (3, 1, 0, 2) + +Dim vIndexes As Variant ' Return value +Dim i As Long +Dim lMin As Long, lMax As Long ' Array bounds +Dim lSwap As Long ' For index swaps + + If IsMissing(pbAscending) Then pbAscending = True + If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False + vIndexes = Array() + lMin = LBound(pvArray, 1) + lMax = UBound(pvArray, 1) + + ' Initialize output array + ReDim vIndexes(lMin To lMax) + For i = lMin To lMax + vIndexes(i) = i + Next i + + ' Initial heapify + For i = (lMax + lMin) \ 2 To lMin Step -1 + SF_Array._HeapSort1(pvArray, vIndexes, i, lMin, lMax, pbCaseSensitive) + Next i + ' Next heapify + For i = lMax To lMin + 1 Step -1 + ' Only indexes as swapped, not the array items themselves + lSwap = vIndexes(i) + vIndexes(i) = vIndexes(lMin) + vIndexes(lMin) = lSwap + SF_Array._HeapSort1(pvArray, vIndexes, lMin, lMin, i - 1, pbCaseSensitive) + Next i + + If pbAscending Then _HeapSort = vIndexes() Else _HeapSort = SF_Array.Reverse(vIndexes()) + +End Function ' ScriptForge.SF_Array._HeapSort + +REM ----------------------------------------------------------------------------- +Private Sub _HeapSort1(ByRef pvArray As Variant _ + , ByRef pvIndexes As Variant _ + , ByVal plIndex As Long _ + , ByVal plMin As Long _ + , ByVal plMax As Long _ + , ByVal pbCaseSensitive As Boolean _ + ) +''' Sub called by _HeapSort only + + Dim lLeaf As Long + Dim lSwap As Long + + Do + lLeaf = plIndex + plIndex - (plMin - 1) + Select Case lLeaf + Case Is > plMax: Exit Do + Case Is < plMax + If SF_Array._ValCompare(pvArray(pvIndexes(lLeaf + 1)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then lLeaf = lLeaf + 1 + End Select + If SF_Array._ValCompare(pvArray(pvIndexes(plIndex)), pvArray(pvIndexes(lLeaf)), pbCaseSensitive) > 0 Then Exit Do + ' Only indexes as swapped, not the array items themselves + lSwap = pvIndexes(plIndex) + pvIndexes(plIndex) = pvIndexes(lLeaf) + pvIndexes(lLeaf) = lSwap + plIndex = lLeaf + Loop + +End Sub ' ScriptForge.SF_Array._HeapSort1 + +REM ----------------------------------------------------------------------------- +Private Function _Repr(ByRef pvArray As Variant) As String +''' Convert array to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' pvArray: the array to convert, individual items may be of any type, including arrays +''' Return: +''' "[ARRAY] (L:U[, L:U]...)" if # of Dims > 1 +''' "[ARRAY] (L:U) (item1,item2, ...)" if 1D array + +Dim iDims As Integer ' Number of dimensions of the array +Dim sArray As String ' Return value +Dim i As Long +Const cstArrayEmpty = "[ARRAY] ()" +Const cstArray = "[ARRAY]" +Const cstMaxLength = 50 ' Maximum length for items +Const cstSeparator = ", " + + _Repr = "" + iDims = SF_Array.CountDims(pvArray) + + Select Case iDims + Case -1 : Exit Function ' Not an array + Case 0 : sArray = cstArrayEmpty + Case Else + sArray = cstArray + For i = 1 To iDims + sArray = sArray & Iif(i = 1, " (", ", ") & CStr(LBound(pvArray, i)) & ":" & CStr(UBound(pvArray, i)) + Next i + sArray = sArray & ")" + ' List individual items of 1D arrays + If iDims = 1 Then + sArray = sArray & " (" + For i = LBound(pvArray) To UBound(pvArray) + sArray = sArray & SF_Utils._Repr(pvArray(i), cstMaxLength) & cstSeparator ' Recursive call + Next i + sArray = Left(sArray, Len(sArray) - Len(cstSeparator)) ' Suppress last comma + sArray = sArray & ")" + End If + End Select + + _Repr = sArray + +End Function ' ScriptForge.SF_Array._Repr + +REM ----------------------------------------------------------------------------- +Public Function _StaticType(ByRef pvArray As Variant) As Integer +''' If array is static, return its type +''' Args: +''' pvArray: array to examine +''' Return: +''' array type, -1 if not identified +''' All numeric types are aggregated into V_NUMERIC + +Dim iArrayType As Integer ' VarType of array +Dim iType As Integer ' VarType of items + + iArrayType = VarType(pvArray) + iType = iArrayType - V_ARRAY + Select Case iType + Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL, V_BOOLEAN + _StaticType = V_NUMERIC + Case V_STRING, V_DATE + _StaticType = iType + Case Else + _StaticType = -1 + End Select + +End Function ' ScriptForge.SF_Utils._StaticType + +REM ----------------------------------------------------------------------------- +Private Function _ValCompare(ByVal pvValue1 As Variant _ + , pvValue2 As Variant _ + , Optional ByVal pbCaseSensitive As Boolean _ + ) As Integer +''' Compare 2 values : equality, greater than or smaller than +''' Args: +''' pvValue1 and pvValue2: values to compare. pvValues must be String, Number, Date, Empty or Null +''' By convention: Empty < Null < string, number or date +''' pbCaseSensitive: ignored when not String comparison +''' Return: -1 when pvValue1 < pvValue2 +''' +1 when pvValue1 > pvValue2 +''' 0 when pvValue1 = pvValue2 +''' -2 when comparison is nonsense + +Dim iCompare As Integer, iVarType1 As Integer, iVarType2 As Integer + + If IsMissing(pbCaseSensitive) Then pbCaseSensitive = False + iVarType1 = SF_Utils._VarTypeExt(pvValue1) + iVarType2 = SF_Utils._VarTypeExt(pvValue2) + + iCompare = -2 + If iVarType1 = V_OBJECT Or iVarType1 = V_BYTE Or iVarType1 >= V_ARRAY Then ' Nonsense + ElseIf iVarType2 = V_OBJECT Or iVarType2 = V_BYTE Or iVarType2 >= V_ARRAY Then ' Nonsense + ElseIf iVarType1 = V_STRING And iVarType2 = V_STRING Then + iCompare = StrComp(pvValue1, pvValue2, Iif(pbCaseSensitive, 1, 0)) + ElseIf iVarType1 = V_NULL Or iVarType1 = V_EMPTY Or iVarType2 = V_NULL Or iVarType2 = V_EMPTY Then + Select Case True + Case pvValue1 = pvValue2 : iCompare = 0 + Case iVarType1 = V_NULL And iVarType2 = V_EMPTY : iCompare = +1 + Case iVarType1 = V_EMPTY And iVarType2 = V_NULL : iCompare = -1 + Case iVarType1 = V_NULL Or iVarType1 = V_EMPTY : iCompare = -1 + Case iVarType2 = V_NULL Or iVarType2 = V_EMPTY : iCompare = +1 + End Select + ElseIf iVarType1 = iVarType2 Then + Select Case True + Case pvValue1 < pvValue2 : iCompare = -1 + Case pvValue1 = pvValue2 : iCompare = 0 + Case pvValue1 > pvValue2 : iCompare = +1 + End Select + End If + + _ValCompare = iCompare + +End Function ' ScriptForge.SF_Array._ValCompare + +REM ================================================= END OF SCRIPTFORGE.SF_ARRAY + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Dictionary.xba b/wizards/source/scriptforge/SF_Dictionary.xba new file mode 100644 index 000000000..22ada5148 --- /dev/null +++ b/wizards/source/scriptforge/SF_Dictionary.xba @@ -0,0 +1,959 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Dictionary +''' ============= +''' Class for management of dictionaries +''' A dictionary is a collection of key-item pairs +''' The key is a not case-sensitive string +''' Items may be of any type +''' Keys, items can be retrieved, counted, etc. +''' +''' The implementation is based on +''' - one collection mapping keys and entries in the array +''' - one 1-column array: key + data +''' +''' Why a Dictionary class beside the builtin Collection class ? +''' A standard Basic collection does not support the retrieval of the keys +''' Additionally it may contain only simple data (strings, numbers, ...) +''' +''' Service instantiation example: +''' Dim myDict As Variant +''' myDict = CreateScriptService("Dictionary") ' Once per dictionary +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_dictionary.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const DUPLICATEKEYERROR = "DUPLICATEKEYERROR" ' Key exists already +Const UNKNOWNKEYERROR = "UNKNOWNKEYERROR" ' Key not found +Const INVALIDKEYERROR = "INVALIDKEYERROR" ' Key contains only spaces + +REM ============================================================= PRIVATE MEMBERS + +' Defines an entry in the MapItems array +Type ItemMap + Key As String + Value As Variant +End Type + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "DICTIONARY" +Private ServiceName As String +Private MapKeys As Variant ' To retain the original keys +Private MapItems As Variant ' Array of ItemMaps +Private _MapSize As Long ' Total number of entries in the dictionary +Private _MapRemoved As Long ' Number of inactive entries in the dictionary + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DICTIONARY" + ServiceName = "ScriptForge.Dictionary" + Set MapKeys = New Collection + Set MapItems = Array() + _MapSize = 0 + _MapRemoved = 0 +End Sub ' ScriptForge.SF_Dictionary Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' ScriptForge.SF_Dictionary Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + RemoveAll() + Set Dispose = Nothing +End Function ' ScriptForge.SF_Dictionary Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Count() As Long +''' Actual number of entries in the dictionary +''' Example: +''' myDict.Count + + Count = _PropertyGet("Count") + +End Property ' ScriptForge.SF_Dictionary.Count + +REM ----------------------------------------------------------------------------- +Public Function Item(Optional ByVal Key As Variant) As Variant +''' Return the value of the item related to Key +''' Args: +''' Key: the key value (string) +''' Returns: +''' Empty if not found, otherwise the found value +''' Example: +''' myDict.Item("ThisKey") +''' NB: defined as a function to not disrupt the Basic IDE debugger + + Item = _PropertyGet("Item", Key) + +End Function ' ScriptForge.SF_Dictionary.Item + +REM ----------------------------------------------------------------------------- +Property Get Items() as Variant +''' Return the list of Items as a 1D array +''' The Items and Keys properties return their respective contents in the same order +''' The order is however not necessarily identical to the creation sequence +''' Returns: +''' The array is empty if the dictionary is empty +''' Examples +''' a = myDict.Items +''' For Each b In a ... + + Items = _PropertyGet("Items") + +End Property ' ScriptForge.SF_Dictionary.Items + +REM ----------------------------------------------------------------------------- +Property Get Keys() as Variant +''' Return the list of keys as a 1D array +''' The Keys and Items properties return their respective contents in the same order +''' The order is however not necessarily identical to the creation sequence +''' Returns: +''' The array is empty if the dictionary is empty +''' Examples +''' a = myDict.Keys +''' For each b In a ... + + Keys = _PropertyGet("Keys") + +End Property ' ScriptForge.SF_Dictionary.Keys + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Add(Optional ByVal Key As Variant _ + , Optional ByVal Item As Variant _ + ) As Boolean +''' Add a new key-item pair into the dictionary +''' Args: +''' Key: must not yet exist in the dictionary +''' Item: any value, including an array, a Basic object, a UNO object, ... +''' Returns: True if successful +''' Exceptions: +''' DUPLICATEKEYERROR: such a key exists already +''' INVALIDKEYERROR: zero-length string or only spaces +''' Examples: +''' myDict.Add("NewKey", NewValue) + +Dim oItemMap As ItemMap ' New entry in the MapItems array +Const cstThisSub = "Dictionary.Add" +Const cstSubArgs = "Key, Item" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Add = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch + If IsArray(Item) Then + If Not SF_Utils._ValidateArray(Item, "Item") Then GoTo Catch + Else + If Not SF_Utils._Validate(Item, "Item") Then GoTo Catch + End If + End If + If Key = Space(Len(Key)) Then GoTo CatchInvalid + If Exists(Key) Then GoTo CatchDuplicate + +Try: + _MapSize = _MapSize + 1 + MapKeys.Add(_MapSize, Key) + oItemMap.Key = Key + oItemMap.Value = Item + ReDim Preserve MapItems(1 To _MapSize) + MapItems(_MapSize) = oItemMap + Add = True + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDuplicate: + SF_Exception.RaiseFatal(DUPLICATEKEYERROR, "Key", Key) + GoTo Finally +CatchInvalid: + SF_Exception.RaiseFatal(INVALIDKEYERROR, "Key") + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.Add + +REM ----------------------------------------------------------------------------- +Public Function ConvertToArray() As Variant +''' Store the content of the dictionary in a 2-columns array: +''' Key stored in 1st column, Item stored in 2nd +''' Args: +''' Returns: +''' a zero-based 2D array(0:Count - 1, 0:1) +''' an empty array if the dictionary is empty + +Dim vArray As Variant ' Return value +Dim sKey As String ' Tempry key +Dim vKeys As Variant ' Array of keys +Dim lCount As Long ' Counter +Const cstThisSub = "Dictionary.ConvertToArray" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + vArray = Array() + If Count = 0 Then + Else + ReDim vArray(0 To Count - 1, 0 To 1) + lCount = -1 + vKeys = Keys + For Each sKey in vKeys + lCount = lCount + 1 + vArray(lCount, 0) = sKey + vArray(lCount, 1) = Item(sKey) + Next sKey + End If + +Finally: + ConvertToArray = vArray() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ConvertToArray + +REM ----------------------------------------------------------------------------- +Public Function ConvertToJson(ByVal Optional Indent As Variant) As Variant +''' Convert the content of the dictionary to a JSON string +''' JSON = JavaScript Object Notation: https://en.wikipedia.org/wiki/JSON +''' Limitations +''' Allowed item types: String, Boolean, numbers, Null and Empty +''' Arrays containing above types are allowed +''' Dates are converted into strings (not within arrays) +''' Other types are converted to their string representation (cfr. SF_String.Represent) +''' Args: +''' Indent: +''' If indent is a non-negative integer or string, then JSON array elements and object members will be pretty-printed with that indent level. +''' An indent level <= 0 will only insert newlines. +''' "", (the default) selects the most compact representation. +''' Using a positive integer indent indents that many spaces per level. +''' If indent is a string (such as Chr(9)), that string is used to indent each level. +''' Returns: +''' the JSON string +''' Example: +''' myDict.Add("p0", 12.5) +''' myDict.Add("p1", "a string àé""ê") +''' myDict.Add("p2", DateSerial(2020,9,28)) +''' myDict.Add("p3", True) +''' myDict.Add("p4", Array(1,2,3)) +''' MsgBox a.ConvertToJson() ' {"p0": 12.5, "p1": "a string \u00e0\u00e9\"\u00ea", "p2": "2020-09-28", "p3": true, "p4": [1, 2, 3]} + +Dim sJson As String ' Return value +Dim vArray As Variant ' Array of property values +Dim oPropertyValue As Object ' com.sun.star.beans.PropertyValue +Dim sKey As String ' Tempry key +Dim vKeys As Variant ' Array of keys +Dim vItem As Variant ' Tempry item +Dim iVarType As Integer ' Extended VarType +Dim lCount As Long ' Counter +Dim vIndent As Variant ' Python alias of Indent +Const cstPyHelper = "$" & "_SF_Dictionary__ConvertToJson" + +Const cstThisSub = "Dictionary.ConvertToJson" +Const cstSubArgs = "[Indent=Null]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Indent) Or IsEmpty(INDENT) Then Indent = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Indent, "Indent", Array(V_STRING, V_NUMERIC)) Then GoTo Finally + End If + sJson = "" + +Try: + vArray = Array() + If Count = 0 Then + Else + ReDim vArray(0 To Count - 1) + lCount = -1 + vKeys = Keys + For Each sKey in vKeys + ' Check item type + vItem = Item(sKey) + iVarType = SF_Utils._VarTypeExt(vItem) + Select Case iVarType + Case V_STRING, V_BOOLEAN, V_NUMERIC, V_NULL, V_EMPTY + Case V_DATE + vItem = SF_Utils._CDateToIso(vItem) + Case >= V_ARRAY + Case Else + vItem = SF_Utils._Repr(vItem) + End Select + ' Build in each array entry a (Name, Value) pair + Set oPropertyValue = SF_Utils._MakePropertyValue(sKey, vItem) + lCount = lCount + 1 + Set vArray(lCount) = oPropertyValue + Next sKey + End If + + 'Pass array to Python script for the JSON conversion + With ScriptForge.SF_Session + vIndent = Indent + If VarType(Indent) = V_STRING Then + If Len(Indent) = 0 Then vIndent = Null + End If + sJson = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, vArray, vIndent) + End With + +Finally: + ConvertToJson = sJson + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ConvertToJson + +REM ----------------------------------------------------------------------------- +Public Function ConvertToPropertyValues() As Variant +''' Store the content of the dictionary in an array of PropertyValues +''' Key stored in Name, Item stored in Value +''' Args: +''' Returns: +''' a zero-based 1D array(0:Count - 1). Each entry is a com.sun.star.beans.PropertyValue +''' Name: the key in the dictionary +''' Value: +''' Dates are converted to UNO dates +''' Empty arrays are replaced by Null +''' an empty array if the dictionary is empty + +Dim vArray As Variant ' Return value +Dim oPropertyValue As Object ' com.sun.star.beans.PropertyValue +Dim sKey As String ' Tempry key +Dim vKeys As Variant ' Array of keys +Dim lCount As Long ' Counter +Const cstThisSub = "Dictionary.ConvertToPropertyValues" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + vArray = Array() + If Count = 0 Then + Else + ReDim vArray(0 To Count - 1) + lCount = -1 + vKeys = Keys + For Each sKey in vKeys + ' Build in each array entry a (Name, Value) pair + Set oPropertyValue = SF_Utils._MakePropertyValue(sKey, Item(sKey)) + lCount = lCount + 1 + Set vArray(lCount) = oPropertyValue + Next sKey + End If + +Finally: + ConvertToPropertyValues = vArray() + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ConvertToPropertyValues + +REM ----------------------------------------------------------------------------- +Public Function Exists(Optional ByVal Key As Variant) As Boolean +''' Determine if a key exists in the dictionary +''' Args: +''' Key: the key value (string) +''' Returns: True if key exists +''' Examples: +''' If myDict.Exists("SomeKey") Then ' don't add again + +Dim vItem As Variant ' Item part in MapKeys +Const cstThisSub = "Dictionary.Exists" +Const cstSubArgs = "Key" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Exists = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch + End If + +Try: + ' Dirty but preferred to go through whole collection + On Local Error GoTo NotFound + vItem = MapKeys(Key) + NotFound: + Exists = ( Not ( Err = 5 ) And vItem > 0 ) + On Local Error GoTo 0 + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.Exists + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByVal Key As Variant _ + ) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Key: mandatory if PropertyName = "Item", ignored otherwise +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myDict.GetProperty("Count") + +Const cstThisSub = "Dictionary.GetProperty" +Const cstSubArgs = "PropertyName, [Key]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If IsMissing(Key) Or IsEmpty(Key) Then Key = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName, Key) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function ImportFromJson(Optional ByVal InputStr As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Adds the content of a Json string into the current dictionary +''' JSON = JavaScript Object Notation: https://en.wikipedia.org/wiki/JSON +''' Limitations +''' The JSON string may contain numbers, strings, booleans, null values and arrays containing those types +''' It must not contain JSON objects, i.e. sub-dictionaries +''' An attempt is made to convert strings to dates if they fit one of next patterns: +''' YYYY-MM-DD, HH:MM:SS or YYYY-MM-DD HH:MM:SS +''' Args: +''' InputStr: the json string to import +''' Overwrite: when True entries with same name may exist in the dictionary and their values are overwritten +''' Default = False +''' Returns: +''' True if successful +''' Exceptions: +''' DUPLICATEKEYERROR: such a key exists already +''' INVALIDKEYERROR: zero-length string or only spaces +''' Example: +''' Dim s As String +''' s = "{'firstName': 'John','lastName': 'Smith','isAlive': true,'age': 66, 'birth': '1954-09-28 20:15:00'" _ +''' & ",'address': {'streetAddress': '21 2nd Street','city': 'New York','state': 'NY','postalCode': '10021-3100'}" _ +''' & ",'phoneNumbers': [{'type': 'home','number': '212 555-1234'},{'type': 'office','number': '646 555-4567'}]" _ +''' & ",'children': ['Q','M','G','T'],'spouse': null}" +''' s = Replace(s, "'", """") +''' myDict.ImportFromJson(s, OverWrite := True) +''' ' The (sub)-dictionaries "address" and "phoneNumbers(0) and (1) are reduced to Empty + +Dim bImport As Boolean ' Return value +Dim vArray As Variant ' JSON string converted to array +Dim vArrayEntry As Variant ' A single entry in vArray +Dim vKey As Variant ' Tempry key +Dim vItem As Variant ' Tempry item +Dim bExists As Boolean ' True when an entry exists +Dim dDate As Date ' String converted to Date +Const cstPyHelper = "$" & "_SF_Dictionary__ImportFromJson" + +Const cstThisSub = "Dictionary.ImportFromJson" +Const cstSubArgs = "InputStr, [Overwrite=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bImport = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoYo Finally + End If + +Try: + With ScriptForge.SF_Session + vArray = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, InputStr) + End With + If Not IsArray(vArray) Then GoTo Finally ' Conversion error or nothing to do + + ' vArray = Array of subarrays = 2D DataArray (cfr. Calc) + For Each vArrayEntry In vArray + vKey = vArrayEntry(0) + If VarType(vKey) = V_STRING Then ' Else skip + vItem = vArrayEntry(1) + If Overwrite Then bExists = Exists(vKey) Else bExists = False + ' When the item matches a date pattern, convert it to a date + If VarType(vItem) = V_STRING Then + dDate = SF_Utils._CStrToDate(vItem) + If dDate > -1 Then vItem = dDate + End If + If bExists Then + ReplaceItem(vKey, vItem) + Else + Add(vKey, vItem) ' Key controls are done in Add + End If + End If + Next vArrayEntry + + bImport = True + +Finally: + ImportFromJson = bImport + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ImportFromJson + +REM ----------------------------------------------------------------------------- +Public Function ImportFromPropertyValues(Optional ByVal PropertyValues As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Adds the content of an array of PropertyValues into the current dictionary +''' Names contain Keys, Values contain Items +''' UNO dates are replaced by Basic dates +''' Args: +''' PropertyValues: a zero-based 1D array. Each entry is a com.sun.star.beans.PropertyValue +''' Overwrite: when True entries with same name may exist in the dictionary and their values are overwritten +''' Default = False +''' Returns: +''' True if successful +''' Exceptions: +''' DUPLICATEKEYERROR: such a key exists already +''' INVALIDKEYERROR: zero-length string or only spaces + +Dim bImport As Boolean ' Return value +Dim oPropertyValue As Object ' com.sun.star.beans.PropertyValue +Dim vItem As Variant ' Tempry item +Dim sObjectType As String ' UNO object type of dates +Dim bExists As Boolean ' True when an entry exists +Const cstThisSub = "Dictionary.ImportFromPropertyValues" +Const cstSubArgs = "PropertyValues, [Overwrite=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bImport = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If IsArray(PropertyValues) Then + If Not SF_Utils._ValidateArray(PropertyValues, "PropertyValues", 1, V_OBJECT, True) Then GoTo Finally + Else + If Not SF_Utils._Validate(PropertyValues, "PropertyValues", V_OBJECT) Then GoTo Finally + End If + If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoYo Finally + End If + +Try: + If Not IsArray(PropertyValues) Then PropertyValues = Array(PropertyValues) + With oPropertyValue + For Each oPropertyValue In PropertyValues + If Overwrite Then bExists = Exists(.Name) Else bExists = False + If SF_Session.UnoObjectType(oPropertyValue) = "com.sun.star.beans.PropertyValue" Then + If IsUnoStruct(.Value) Then + sObjectType = SF_Session.UnoObjectType(.Value) + Select Case sObjectType + Case "com.sun.star.util.DateTime" : vItem = CDateFromUnoDateTime(.Value) + Case "com.sun.star.util.Date" : vItem = CDateFromUnoDate(.Value) + Case "com.sun.star.util.Time" : vItem = CDateFromUnoTime(.Value) + Case Else : vItem = .Value + End Select + Else + vItem = .Value + End If + If bExists Then + ReplaceItem(.Name, vItem) + Else + Add(.Name, vItem) ' Key controls are done in Add + End If + End If + Next oPropertyValue + End With + bImport = True + +Finally: + ImportFromPropertyValues = bImport + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ImportFromPropertyValues + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list or methods of the Dictionary class as an array + + Methods = Array( _ + "Add" _ + , "ConvertToArray" _ + , "ConvertToJson" _ + , "ConvertToPropertyValues" _ + , "Exists" _ + , "ImportFromJson" _ + , "ImportFromPropertyValues" _ + , "Remove" _ + , "RemoveAll" _ + , "ReplaceItem" _ + , "ReplaceKey" _ + ) + +End Function ' ScriptForge.SF_Dictionary.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Dictionary class as an array + + Properties = Array( _ + "Count" _ + , "Item" _ + , "Items" _ + , "Keys" _ + ) + +End Function ' ScriptForge.SF_Dictionary.Properties + +REM ----------------------------------------------------------------------------- +Public Function Remove(Optional ByVal Key As Variant) As Boolean +''' Remove an existing dictionary entry based on its key +''' Args: +''' Key: must exist in the dictionary +''' Returns: True if successful +''' Exceptions: +''' UNKNOWNKEYERROR: the key does not exist +''' Examples: +''' myDict.Remove("OldKey") + +Dim lIndex As Long ' To remove entry in the MapItems array +Const cstThisSub = "Dictionary.Remove" +Const cstSubArgs = "Key" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Remove = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch + End If + If Not Exists(Key) Then GoTo CatchUnknown + +Try: + lIndex = MapKeys.Item(Key) + MapKeys.Remove(Key) + Erase MapItems(lIndex) ' Is now Empty + _MapRemoved = _MapRemoved + 1 + Remove = True + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchUnknown: + SF_Exception.RaiseFatal(UNKNOWNKEYERROR, "Key", Key) + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.Remove + +REM ----------------------------------------------------------------------------- +Public Function RemoveAll() As Boolean +''' Remove all the entries from the dictionary +''' Args: +''' Returns: True if successful +''' Examples: +''' myDict.RemoveAll() + +Dim vKeys As Variant ' Array of keys +Dim sColl As String ' A collection key in MapKeys +Const cstThisSub = "Dictionary.RemoveAll" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + RemoveAll = False + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + vKeys = Keys + For Each sColl In vKeys + MapKeys.Remove(sColl) + Next sColl + Erase MapKeys + Erase MapItems + ' Make dictionary ready to receive new entries + Call Class_Initialize() + RemoveAll = True + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.RemoveAll + +REM ----------------------------------------------------------------------------- +Public Function ReplaceItem(Optional ByVal Key As Variant _ + , Optional ByVal Value As Variant _ + ) As Boolean +''' Replace the item value +''' Args: +''' Key: must exist in the dictionary +''' Returns: True if successful +''' Exceptions: +''' UNKNOWNKEYERROR: the old key does not exist +''' Examples: +''' myDict.ReplaceItem("Key", NewValue) + +Dim oItemMap As ItemMap ' Content to update in the MapItems array +Dim lIndex As Long ' Entry in the MapItems array +Const cstThisSub = "Dictionary.ReplaceItem" +Const cstSubArgs = "Key, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + ReplaceItem = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch + If IsArray(Value) Then + If Not SF_Utils._ValidateArray(Value, "Value") Then GoTo Catch + Else + If Not SF_Utils._Validate(Value, "Value") Then GoTo Catch + End If + End If + If Not Exists(Key) Then GoTo CatchUnknown + +Try: + ' Find entry in MapItems and update it with the new value + lIndex = MapKeys.Item(Key) + oItemMap = MapItems(lIndex) + oItemMap.Value = Value + ReplaceItem = True + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchUnknown: + SF_Exception.RaiseFatal(UNKNOWNKEYERROR, "Key", Key) + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ReplaceItem + +REM ----------------------------------------------------------------------------- +Public Function ReplaceKey(Optional ByVal Key As Variant _ + , Optional ByVal Value As Variant _ + ) As Boolean +''' Replace existing key +''' Args: +''' Key: must exist in the dictionary +''' Value: must not exist in the dictionary +''' Returns: True if successful +''' Exceptions: +''' UNKNOWNKEYERROR: the old key does not exist +''' DUPLICATEKEYERROR: the new key exists +''' Examples: +''' myDict.ReplaceKey("OldKey", "NewKey") + +Dim oItemMap As ItemMap ' Content to update in the MapItems array +Dim lIndex As Long ' Entry in the MapItems array +Const cstThisSub = "Dictionary.ReplaceKey" +Const cstSubArgs = "Key, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + ReplaceKey = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch + If Not SF_Utils._Validate(Value, "Value", V_STRING) Then GoTo Catch + End If + If Not Exists(Key) Then GoTo CatchUnknown + If Value = Space(Len(Value)) Then GoTo CatchInvalid + If Exists(Value) Then GoTo CatchDuplicate + +Try: + ' Remove the Key entry and create a new one in MapKeys + With MapKeys + lIndex = .Item(Key) + .Remove(Key) + .Add(lIndex, Value) + End With + oItemMap = MapItems(lIndex) + oItemMap.Key = Value + ReplaceKey = True + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchUnknown: + SF_Exception.RaiseFatal(UNKNOWNKEYERROR, "Key", Key) + GoTo Finally +CatchDuplicate: + SF_Exception.RaiseFatal(DUPLICATEKEYERROR, "Value", Value) + GoTo Finally +CatchInvalid: + SF_Exception.RaiseFatal(INVALIDKEYERROR, "Key") + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.ReplaceKey + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Dictionary.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional pvKey As Variant _ + ) +''' Return the named property +''' Args: +''' psProperty: the name of the property +''' pvKey: the key to retrieve, numeric or string + +Dim vItemMap As Variant ' Entry in the MapItems array +Dim vArray As Variant ' To get Keys or Values +Dim i As Long +Dim cstThisSub As String +Dim cstSubArgs As String + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + cstThisSub = "SF_Dictionary.get" & psProperty + If IsMissing(pvKey) Then cstSubArgs = "" Else cstSubArgs = "[Key]" + + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case UCase(psProperty) + Case UCase("Count") + _PropertyGet = _MapSize - _MapRemoved + Case UCase("Item") + If Not SF_Utils._Validate(pvKey, "Key", V_STRING) Then GoTo Catch + If Exists(pvKey) Then _PropertyGet = MapItems(MapKeys(pvKey)).Value Else _PropertyGet = Empty + Case UCase("Keys"), UCase("Items") + vArray = Array() + If _MapSize - _MapRemoved - 1 >= 0 Then + ReDim vArray(0 To (_MapSize - _MapRemoved - 1)) + i = -1 + For each vItemMap In MapItems() + If Not IsEmpty(vItemMap) Then + i = i + 1 + If UCase(psProperty) = "KEYS" Then vArray(i) = vItemMap.Key Else vArray(i) = vItemMap.Value + End If + Next vItemMap + End If + _PropertyGet = vArray + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Dictionary._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Dictionary instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Dictionary] (key1:value1, key2:value2, ...) + +Dim sDict As String ' Return value +Dim vKeys As Variant ' Array of keys +Dim sKey As String ' Tempry key +Dim vItem As Variant ' Tempry item +Const cstDictEmpty = "[Dictionary] ()" +Const cstDict = "[Dictionary]" +Const cstMaxLength = 50 ' Maximum length for items +Const cstSeparator = ", " + + _Repr = "" + + If Count = 0 Then + sDict = cstDictEmpty + Else + sDict = cstDict & " (" + vKeys = Keys + For Each sKey in vKeys + vItem = Item(sKey) + sDict = sDict & sKey & ":" & SF_Utils._Repr(vItem, cstMaxLength) & cstSeparator + Next sKey + sDict = Left(sDict, Len(sDict) - Len(cstSeparator)) & ")" ' Suppress last comma + End If + + _Repr = sDict + +End Function ' ScriptForge.SF_Dictionary._Repr + +REM ============================================ END OF SCRIPTFORGE.SF_DICTIONARY + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Exception.xba b/wizards/source/scriptforge/SF_Exception.xba new file mode 100644 index 000000000..11e97b02b --- /dev/null +++ b/wizards/source/scriptforge/SF_Exception.xba @@ -0,0 +1,1381 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' Exception (aka SF_Exception) +''' ========= +''' Generic singleton class for Basic code debugging and error handling +''' +''' Errors may be generated by +''' the Basic run-time error detection +''' in the ScriptForge code => RaiseAbort() +''' in a user code => Raise() +''' an error detection implemented +''' in the ScriptForge code => RaiseFatal() +''' in a user code => Raise() or RaiseWarning() +''' +''' When a run-time error occurs, the properties of the Exception object are filled +''' with information that uniquely identifies the error and information that can be used to handle it +''' The SF_Exception object is in this context similar to the VBA Err object +''' See https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/err-object +''' The Number property identifies the error: it can be a numeric value or a string +''' Numeric values up to 2000 are considered Basic run-time errors +''' +''' The "console" logs events, actual variable values, errors, ... It is an easy mean +''' to debug Basic programs especially when the IDE is not usable, f.i. in Calc user defined functions +''' or during control events processing +''' => DebugPrint() +''' +''' The usual behaviour of the application when an error occurs is: +''' 1. Log the error in the console +''' 2, Inform the user about the error with either a standard or a customized message +''' 3. Optionally, stop the execution of the current macro +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_exception.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +' SF_Utils +Const MISSINGARGERROR = "MISSINGARGERROR" +Const ARGUMENTERROR = "ARGUMENTERROR" +Const ARRAYERROR = "ARRAYERROR" +Const FILEERROR = "FILEERROR" + +' SF_Array +Const ARRAYSEQUENCEERROR = "ARRAYSEQUENCEERROR" +Const ARRAYINSERTERROR = "ARRAYINSERTERROR" +Const ARRAYINDEX1ERROR = "ARRAYINDEX1ERROR" +Const ARRAYINDEX2ERROR = "ARRAYINDEX2ERROR" +Const CSVPARSINGERROR = "CSVPARSINGERROR" +Const CSVOVERFLOWWARNING = "CSVOVERFLOWWARNING" + +' SF_Dictionary +Const DUPLICATEKEYERROR = "DUPLICATEKEYERROR" +Const UNKNOWNKEYERROR = "UNKNOWNKEYERROR" +Const INVALIDKEYERROR = "INVALIDKEYERROR" + +' SF_FileSystem +Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" +Const UNKNOWNFOLDERERROR = "UNKNOWNFOLDERERROR" +Const NOTAFILEERROR = "NOTAFILEERROR" +Const NOTAFOLDERERROR = "NOTAFOLDERERROR" +Const OVERWRITEERROR = "OVERWRITEERROR" +Const READONLYERROR = "READONLYERROR" +Const NOFILEMATCHERROR = "NOFILEMATCHFOUND" +Const FOLDERCREATIONERROR = "FOLDERCREATIONERROR" + +' SF_Services +Const UNKNOWNSERVICEERROR = "UNKNOWNSERVICEERROR" +Const SERVICESNOTLOADEDERROR = "SERVICESNOTLOADEDERROR" + +' SF_Session +Const CALCFUNCERROR = "CALCFUNCERROR" +Const NOSCRIPTERROR = "NOSCRIPTERROR" +Const SCRIPTEXECERROR = "SCRIPTEXECERROR" +Const WRONGEMAILERROR = "WRONGEMAILERROR" +Const SENDMAILERROR = "SENDMAILERROR" + +' SF_TextStream +Const FILENOTOPENERROR = "FILENOTOPENERROR" +Const FILEOPENMODEERROR = "FILEOPENMODEERROR" +Const ENDOFFILEERROR = "ENDOFFILEERROR" + +' SF_UI +Const DOCUMENTERROR = "DOCUMENTERROR" +Const DOCUMENTCREATIONERROR = "DOCUMENTCREATIONERROR" +Const DOCUMENTOPENERROR = "DOCUMENTOPENERROR" +Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR" + +' SF_Document +Const DOCUMENTDEADERROR = "DOCUMENTDEADERROR" +Const DOCUMENTSAVEERROR = "DOCUMENTSAVEERROR" +Const DOCUMENTSAVEASERROR = "DOCUMENTSAVEASERROR" +Const DOCUMENTREADONLYERROR = "DOCUMENTREADONLYERROR" +Const DBCONNECTERROR = "DBCONNECTERROR" + +' SF_Calc +Const CALCADDRESSERROR = "CALCADDRESSERROR" +Const DUPLICATESHEETERROR = "DUPLICATESHEETERROR" +Const OFFSETADDRESSERROR = "OFFSETADDRESSERROR" +Const DUPLICATECHARTERROR = "DUPLICATECHARTERROR" +Const RANGEEXPORTERROR = "RANGEEXPORTERROR" + +' SF_Chart +Const CHARTEXPORTERROR = "CHARTEXPORTERROR" + +' SF_Form +Const FORMDEADERROR = "FORMDEADERROR" +Const CALCFORMNOTFOUNDERROR = "CALCFORMNOTFOUNDERROR" +Const WRITERFORMNOTFOUNDERROR = "WRITERFORMNOTFOUNDERROR" +Const BASEFORMNOTFOUNDERROR = "BASEFORMNOTFOUNDERROR" +Const SUBFORMNOTFOUNDERROR = "SUBFORMNOTFOUNDERROR" +Const FORMCONTROLTYPEERROR = "FORMCONTROLTYPEERROR" + +' SF_Dialog +Const DIALOGNOTFOUNDERROR = "DIALOGNOTFOUNDERROR" +Const DIALOGDEADERROR = "DIALOGDEADERROR" +Const CONTROLTYPEERROR = "CONTROLTYPEERROR" +Const TEXTFIELDERROR = "TEXTFIELDERROR" + +' SF_Database +Const DBREADONLYERROR = "DBREADONLYERROR" +Const SQLSYNTAXERROR = "SQLSYNTAXERROR" + +' Python +Const PYTHONSHELLERROR = "PYTHONSHELLERROR" + +' SF_UnitTest +Const UNITTESTLIBRARYERROR = "UNITTESTLIBRARYERROR" +Const UNITTESTMETHODERROR = "UNITTESTMETHODERROR" + +REM ============================================================= PRIVATE MEMBERS + +' User defined errors +Private _Number As Variant ' Error number/code (Integer or String) +Private _Source As Variant ' Where the error occurred: a module, a Sub/Function, ... +Private _Description As String ' The error message + +' System run-time errors +Private _SysNumber As Long ' Alias of Err +Private _SysSource As Long ' Alias of Erl +Private _SysDescription As String ' Alias of Error$ + +REM ============================================================ MODULE CONSTANTS + +Const RUNTIMEERRORS = 2000 ' Upper limit of Basic run-time errors +Const CONSOLENAME = "ConsoleLines" ' Name of control in the console dialog + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_Exception Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant +''' Returns the description of the last error that has occurred +''' Example: +''' myException.Description + Description = _PropertyGet("Description") +End Property ' ScriptForge.SF_Exception.Description (get) + +REM ----------------------------------------------------------------------------- +Property Let Description(ByVal pvDescription As Variant) +''' Set the description of the last error that has occurred +''' Example: +''' myException.Description = "Not smart to divide by zero" + _PropertySet "Description", pvDescription +End Property ' ScriptForge.SF_Exception.Description (let) + +REM ----------------------------------------------------------------------------- +Property Get Number() As Variant +''' Returns the code of the last error that has occurred +''' Example: +''' myException.Number + Number = _PropertyGet("Number") +End Property ' ScriptForge.SF_Exception.Number (get) + +REM ----------------------------------------------------------------------------- +Property Let Number(ByVal pvNumber As Variant) +''' Set the code of the last error that has occurred +''' Example: +''' myException.Number = 11 ' Division by 0 + _PropertySet "Number", pvNumber +End Property ' ScriptForge.SF_Exception.Number (let) + +REM ----------------------------------------------------------------------------- +Property Get Source() As Variant +''' Returns the location of the last error that has occurred +''' Example: +''' myException.Source + Source = _PropertyGet("Source") +End Property ' ScriptForge.SF_Exception.Source (get) + +REM ----------------------------------------------------------------------------- +Property Let Source(ByVal pvSource As Variant) +''' Set the location of the last error that has occurred +''' Example: +''' myException.Source = 123 ' Line # 123. Source may also be a string + _PropertySet "Source", pvSource +End Property ' ScriptForge.SF_Exception.Source (let) + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_Exception" +End Property ' ScriptForge.SF_String.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.Exception" +End Property ' ScriptForge.SF_Exception.ServiceName + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Sub Clear() +''' Reset the current error status and clear the SF_Exception object +''' Args: +''' Examples: +''' On Local Error GoTo Catch +''' ' ... +''' Catch: +''' SF_Exception.Clear() ' Deny the error + +Const cstThisSub = "Exception.Clear" +Const cstSubArgs = "" + +Check: + +Try: + With SF_Exception + ._Number = Empty + ._Source = Empty + ._Description = "" + ._SysNumber = 0 + ._SysSource = 0 + ._SysDescription = "" + End With + +Finally: + On Error GoTo 0 + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Exception.Clear + +REM ----------------------------------------------------------------------------- +Public Sub Console(Optional ByVal Modal As Variant, _ + Optional ByRef _Context As Variant _ + ) +''' Display the console messages in a modal or non-modal dialog +''' If the dialog is already active, when non-modal, it is brought to front +''' Args: +''' Modal: Boolean. Default = True +''' _Context: From Python, the XComponentXontext (FOR INTERNAL USE ONLY) +''' Example: +''' SF_Exception.Console() + +Dim bConsoleActive As Boolean ' When True, dialog is active +Dim oModalBtn As Object ' Modal close button +Dim oNonModalBtn As Object ' Non modal close button +Const cstThisSub = "Exception.Console" +Const cstSubArgs = "[Modal=True]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Finally ' Never interrupt processing + +Check: + If IsMissing(Modal) Or IsEmpty(Modal) Then Modal = True + If IsMissing(_Context) Or IsEmpty(_Context) Then _Context = Nothing + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Modal, "Modal", V_BOOLEAN) Then GoTo Finally + End If + +Try: + With _SF_ + bConsoleActive = False + If Not IsNull(.ConsoleDialog) Then bConsoleActive = .ConsoleDialog._IsStillAlive(False) ' False to not raise an error + If bConsoleActive And Modal = False Then + ' Bring to front + .ConsoleDialog.Activate() + Else + ' Initialize dialog and fill with actual data + ' The dual modes (modal and non-modal) require to have 2 close buttons o/w only 1 is visible + ' - a usual OK button + ' - a Default button triggering the Close action + Set .ConsoleDialog = CreateScriptService("SFDialogs.Dialog", "GlobalScope", "ScriptForge", "dlgConsole", _Context) + ' Setup labels and visibility + Set oModalBtn = .ConsoleDialog.Controls("CloseModalButton") + Set oNonModalBtn = .ConsoleDialog.Controls("CloseNonModalButton") + oModalBtn.Visible = Modal + oNonModalBtn.Visible = CBool(Not Modal) + ' Load console lines + _ConsoleRefresh() + .ConsoleDialog.Execute(Modal) + ' Terminate the modal dialog + If Modal Then + Set .ConsoleControl = .ConsoleControl.Dispose() + Set .ConsoleDialog = .ConsoleDialog.Dispose() + End If + End If + End With + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' ScriptForge.SF_Exception.Console + +REM ----------------------------------------------------------------------------- +Public Sub ConsoleClear(Optional ByVal Keep) +''' Clear the console keeping an optional number of recent messages +''' Args: +''' Keep: the number of messages to keep +''' If Keep is bigger than the number of messages stored in the console, +''' the console is not cleared +''' Example: +''' SF_Exception.ConsoleClear(5) + +Dim lConsole As Long ' UBound of ConsoleLines +Const cstThisSub = "Exception.ConsoleClear" +Const cstSubArgs = "[Keep=0]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Finally ' Never interrupt processing + +Check: + If IsMissing(Keep) Or IsEmpty(Keep) Then Keep = 0 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Keep, "Keep", V_NUMERIC) Then GoTo Finally + End If + +Try: + With _SF_ + If Keep <= 0 Then + .ConsoleLines = Array() + Else + lConsole = UBound(.ConsoleLines) + If Keep < lConsole + 1 Then .ConsoleLines = SF_Array.Slice(.ConsoleLines, lConsole - Keep + 1) + End If + End With + + ' If active, the console dialog needs to be refreshed + _ConsoleRefresh() + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' ScriptForge.SF_Exception.ConsoleClear + +REM ----------------------------------------------------------------------------- +Public Function ConsoleToFile(Optional ByVal FileName As Variant) As Boolean +''' Export the content of the console to a text file +''' If the file exists and the console is not empty, it is overwritten without warning +''' Args: +''' FileName: the complete file name to export to. If it exists, is overwritten without warning +''' Returns: +''' True if the file could be created +''' Examples: +''' SF_Exception.ConsoleToFile("myFile.txt") + +Dim bExport As Boolean ' Return value +Dim oFile As Object ' Output file handler +Dim sLine As String ' A single line +Const cstThisSub = "Exception.ConsoleToFile" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bExport = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + +Try: + + If UBound(_SF_.ConsoleLines) > -1 Then + Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True) + If Not IsNull(oFile) Then + With oFile + For Each sLine In _SF_.ConsoleLines + .WriteLine(sLine) + Next sLine + .CloseFile() + End With + End If + bExport = True + End If + +Finally: + If Not IsNull(oFile) Then Set oFile = oFile.Dispose() + ConsoleToFile = bExport + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Exception.ConsoleToFile + +REM ----------------------------------------------------------------------------- +Public Sub DebugDisplay(ParamArray pvArgs() As Variant) +''' Display the list of arguments in a readable form in a message box +''' Arguments are separated by a LINEFEED character +''' The maximum length of each individual argument = 1024 characters +''' Args: +''' Any number of arguments of any type +''' Examples: +''' SF_Exception.DebugDisplay(a, Array(1, 2, 3), , "line1" & Chr(10) & "Line2", DateSerial(2020, 04, 09)) + +Dim sOutputMsg As String ' Line to display +Dim sOutputCon As String ' Line to write in console +Dim sArgMsg As String ' Single argument +Dim sArgCon As String ' Single argument +Dim i As Integer +Const cstTab = 4 +Const cstMaxLength = 1024 +Const cstThisSub = "Exception.DebugDisplay" +Const cstSubArgs = "Arg0, [Arg1, ...]" + + If SF_Utils._ErrorHandling() Then On Local Error Goto Finally ' Never interrupt processing + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) +Try: + ' Build new console line + sOutputMsg = "" : sOutputCon = "" + For i = 0 To UBound(pvArgs) + If IsError(pvArgs(i)) Then pvArgs(i) = "" + sArgMsg = Iif(i = 0, "", SF_String.sfNEWLINE) & SF_Utils._Repr(pvArgs(i), cstMaxLength) 'Do not use SF_String.Represent() + sArgCon = Iif(i = 0, "", SF_String.sfTAB) & SF_Utils._Repr(pvArgs(i), cstMaxLength) + sOutputMsg = sOutputMsg & sArgMsg + sOutputCon = sOutputCon & sArgCon + Next i + + ' Add to actual console + _SF_._AddToConsole(SF_String.ExpandTabs(sOutputCon, cstTab)) + ' Display the message + MsgBox(sOutputMsg, MB_OK + MB_ICONINFORMATION, "DebugDisplay") + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' ScriptForge.SF_Exception.DebugDisplay + +REM ----------------------------------------------------------------------------- +Public Sub DebugPrint(ParamArray pvArgs() As Variant) +''' Print the list of arguments in a readable form in the console +''' Arguments are separated by a TAB character (simulated by spaces) +''' The maximum length of each individual argument = 1024 characters +''' Args: +''' Any number of arguments of any type +''' Examples: +''' SF_Exception.DebugPrint(a, Array(1, 2, 3), , "line1" & Chr(10) & "Line2", DateSerial(2020, 04, 09)) + +Dim sOutput As String ' Line to write in console +Dim sArg As String ' Single argument +Dim i As Integer +Const cstTab = 4 +Const cstMaxLength = 1024 +Const cstThisSub = "Exception.DebugPrint" +Const cstSubArgs = "Arg0, [Arg1, ...]" + + If SF_Utils._ErrorHandling() Then On Local Error Goto Finally ' Never interrupt processing + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) +Try: + ' Build new console line + sOutput = "" + For i = 0 To UBound(pvArgs) + If IsError(pvArgs(i)) Then pvArgs(i) = "" + sArg = Iif(i = 0, "", SF_String.sfTAB) & SF_Utils._Repr(pvArgs(i), cstMaxLength) 'Do not use SF_String.Represent() + sOutput = sOutput & sArg + Next i + + ' Add to actual console + _SF_._AddToConsole(SF_String.ExpandTabs(sOutput, cstTab)) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' ScriptForge.SF_Exception.DebugPrint + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myException.GetProperty("MyProperty") + +Const cstThisSub = "Exception.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Exception.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Exception service as an array + + Methods = Array( _ + "Clear" _ + , "Console" _ + , "ConsoleClear" _ + , "ConsoleToFile" _ + , "DebugPrint" _ + , "Raise" _ + , "RaiseAbort" _ + , "RaiseFatal" _ + , "RaiseWarning" _ + ) + +End Function ' ScriptForge.SF_Exception.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "Description" _ + , "Number" _ + , "Source" _ + ) + +End Function ' ScriptForge.SF_Exception.Properties + +REM ----------------------------------------------------------------------------- +Public Sub PythonPrint(ParamArray pvArgs() As Variant) +''' Display the list of arguments in a readable form in the Python console +''' Arguments are separated by a TAB character (simulated by spaces) +''' The maximum length of each individual argument = 1024 characters +''' Args: +''' Any number of arguments of any type +''' Examples: +''' SF_Exception.PythonPrint(a, Array(1, 2, 3), , "line1" & Chr(10) & "Line2", DateSerial(2020, 04, 09)) + +Dim sOutput As String ' Line to write in console +Dim sArg As String ' Single argument +Dim i As Integer +Const cstTab = 4 +Const cstMaxLength = 1024 +Const cstPyHelper = "$" & "_SF_Exception__PythonPrint" +Const cstThisSub = "Exception.PythonPrint" +Const cstSubArgs = "Arg0, [Arg1, ...]" + + If SF_Utils._ErrorHandling() Then On Local Error Goto Finally ' Never interrupt processing + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) +Try: + ' Build new console line + sOutput = "" + For i = 0 To UBound(pvArgs) + If IsError(pvArgs(i)) Then pvArgs(i) = "" + sArg = Iif(i = 0, "", SF_String.sfTAB) & SF_Utils._Repr(pvArgs(i), cstMaxLength) + sOutput = sOutput & sArg + Next i + + ' Add to actual console + sOutput = SF_String.ExpandTabs(sOutput, cstTab) + _SF_._AddToConsole(sOutput) + ' Display the message in the Python shell console + With ScriptForge.SF_Session + .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, sOutput) + End With + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' ScriptForge.SF_Exception.PythonPrint + +REM ----------------------------------------------------------------------------- +Public Sub Raise(Optional ByVal Number As Variant _ + , Optional ByVal Source As Variant _ + , Optional ByVal Description As Variant _ + ) +''' Generate a run-time error. An error message is displayed to the user and logged +''' in the console. The execution is STOPPED +''' Args: +''' Number: the error number, may be numeric or string +''' If numeric and <= 2000, it is considered a LibreOffice Basic run-time error (default = Err) +''' Source: the line where the error occurred (default = Erl) or any string describing the location of the error +''' Description: the error message to log in the console and to display to the user +''' Examples: +''' On Local Error GoTo Catch +''' ' ... +''' Catch: +''' SF_Exception.Raise() ' Standard behaviour +''' SF_Exception.Raise(11) ' Force division by zero +''' SF_Exception.Raise("MYAPPERROR", "myFunction", "Application error") +''' SF_Exception.Raise(,, "To divide by zero is not a good idea !") + +Dim sMessage As String ' Error message to log and to display +Dim L10N As Object ' Alias to LocalizedInterface +Const cstThisSub = "Exception.Raise" +Const cstSubArgs = "[Number=Err], [Source=Erl], [Description]" + + ' Save Err, Erl, .. values before any On Error ... statement + SF_Exception._CaptureSystemError() + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Number) Or IsEmpty(Number) Then Number = -1 + If IsMissing(Source) Or IsEmpty(Source) Then Source = -1 + If IsMissing(Description) Or IsEmpty(Description) Then Description = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Number, "Number", Array(V_STRING, V_NUMERIC)) Then GoTo Finally + If Not SF_Utils._Validate(Source, "Source", Array(V_STRING, V_NUMERIC)) Then GoTo Finally + If Not SF_Utils._Validate(Description, "Description", V_STRING) Then GoTo Finally + End If + +Try: + With SF_Exception + If Number >= 0 Then .Number = Number + If VarType(Source) = V_STRING Then + If Len(Source) > 0 Then .Source = Source + ElseIf Source >= 0 Then ' -1 = Default => no change + .Source = Source + End If + If Len(Description) > 0 Then .Description = Description + + ' Log and display + Set L10N = _SF_._GetLocalizedInterface() + sMessage = L10N.GetText("LONGERRORDESC", .Number, .Source, .Description) + .DebugPrint(sMessage) + If _SF_.DisplayEnabled Then MsgBox L10N.GetText("ERRORNUMBER", .Number) _ + & SF_String.sfNewLine & L10N.GetText("ERRORLOCATION", .Source) _ + & SF_String.sfNewLine & .Description _ + , MB_OK + MB_ICONSTOP _ + , L10N.GetText("ERRORNUMBER", .Number) + .Clear() + End With + +Finally: + SF_Utils._ExitFunction(cstThisSub) + If _SF_.StopWhenError Then + _SF_._StackReset() + Stop + End If + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Exception.Raise + +REM ----------------------------------------------------------------------------- +Public Sub RaiseAbort(Optional ByVal Source As Variant) +''' Manage a run-time error that occurred inside the ScriptForge piece of software itself. +''' The event is logged. +''' The execution is STOPPED +''' For INTERNAL USE only +''' Args: +''' Source: the line where the error occurred + +Dim sLocation As String ' Common header in error messages: location of error +Dim vLocation As Variant ' Split array (library, module, method) +Dim sMessage As String ' Error message to log and to display +Dim L10N As Object ' Alias to LocalizedInterface +Const cstTabSize = 4 +Const cstThisSub = "Exception.RaiseAbort" +Const cstSubArgs = "[Source=Erl]" + + ' Save Err, Erl, .. values before any On Error ... statement + SF_Exception._CaptureSystemError() + On Local Error Resume Next + +Check: + If IsMissing(Source) Or IsEmpty(Source) Then Source = "" + +Try: + With SF_Exception + + ' Prepare message header + Set L10N = _SF_._GetLocalizedInterface() + If Len(_SF_.MainFunction) > 0 Then ' MainFunction = [Library.]Module.Method + vLocation = Split(_SF_.MainFunction, ".") + If UBound(vLocation) < 2 Then vLocation = SF_Array.Prepend(vLocation, "ScriptForge") + sLocation = L10N.GetText("VALIDATESOURCE", vLocation(0), vLocation(1), vLocation(2)) & "\n\n\n" + Else + sLocation = "" + End If + + ' Log and display + sMessage = L10N.GetText("LONGERRORDESC", .Number, .Source, .Description) + .DebugPrint(sMessage) + If _SF_.DisplayEnabled Then + sMessage = sLocation _ + & L10N.GetText("INTERNALERROR") _ + & L10N.GetText("ERRORLOCATION", Source & "/" & .Source) & SF_String.sfNewLine & .Description _ + & "\n" & "\n" & "\n" & L10N.GetText("STOPEXECUTION") + MsgBox SF_String.ExpandTabs(SF_String.Unescape(sMessage), cstTabSize) _ + , MB_OK + MB_ICONSTOP _ + , L10N.GetText("ERRORNUMBER", .Number) + End If + + .Clear() + End With + +Finally: + _SF_._StackReset() + If _SF_.StopWhenError Then Stop + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Exception.RaiseAbort + +REM ----------------------------------------------------------------------------- +Public Sub RaiseFatal(Optional ByVal ErrorCode As Variant _ + , ParamArray pvArgs _ + ) +''' Generate a run-time error caused by an anomaly in a user script detected by ScriptForge +''' The message is logged in the console. The execution is STOPPED +''' For INTERNAL USE only +''' Args: +''' ErrorCode: as a string, the unique identifier of the error +''' pvArgs: the arguments to insert in the error message + +Dim sLocation As String ' Common header in error messages: location of error +Dim sService As String ' Service name having detected the error +Dim sMethod As String ' Method name having detected the error +Dim vLocation As Variant ' Split array (library, module, method) +Dim sMessage As String ' Message to log and display +Dim L10N As Object ' Alias of LocalizedInterface +Dim sAlt As String ' Alternative error messages +Dim iButtons As Integer ' MB_OK or MB_YESNO +Dim iMsgBox As Integer ' Return value of the message box + +Const cstTabSize = 4 +Const cstThisSub = "Exception.RaiseFatal" +Const cstSubArgs = "ErrorCode, [Arg0[, Arg1 ...]]" +Const cstStop = "⏻" ' Chr(9211) + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(ErrorCode) Or IsEmpty(ErrorCode) Then ErrorCode = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(ErrorCode, "ErrorCode", V_STRING) Then GoTo Finally + End If + +Try: + Set L10N = _SF_._GetLocalizedInterface() + ' Location header common to all error messages + If Len(_SF_.MainFunction) > 0 Then ' MainFunction = [Library.]Module.Method + vLocation = Split(_SF_.MainFunction, ".") + If UBound(vLocation) < 2 Then vLocation = SF_Array.Prepend(vLocation, "ScriptForge") + sService = vLocation(1) + sMethod = vLocation(2) + sLocation = L10N.GetText("VALIDATESOURCE", vLocation(0), sService, sMethod) _ + & "\n" & L10N.GetText("VALIDATEARGS", _RightCaseArgs(_SF_.MainFunctionArgs)) + Else + sService = "" + sMethod = "" + sLocation = "" + End If + + With L10N + Select Case UCase(ErrorCode) + Case MISSINGARGERROR ' SF_Utils._Validate(Name) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("VALIDATEMISSING", pvArgs(0)) + Case ARGUMENTERROR ' SF_Utils._Validate(Value, Name, Types, Values, Regex, Class) + pvArgs(1) = _RightCase(pvArgs(1)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(1)) _ + & "\n" & "\n" & .GetText("VALIDATIONRULES") + If Len(pvArgs(2)) > 0 Then sMessage = sMessage & "\n" & .GetText("VALIDATETYPES", pvArgs(1), pvArgs(2)) + If Len(pvArgs(3)) > 0 Then sMessage = sMessage & "\n" & .GetText("VALIDATEVALUES", pvArgs(1), pvArgs(3)) + If Len(pvArgs(4)) > 0 Then sMessage = sMessage & "\n" & .GetText("VALIDATEREGEX", pvArgs(1), pvArgs(4)) + If Len(pvArgs(5)) > 0 Then sMessage = sMessage & "\n" & .GetText("VALIDATECLASS", pvArgs(1), pvArgs(5)) + sMessage = sMessage & "\n" & "\n" & .GetText("VALIDATEACTUAL", pvArgs(1), pvArgs(0)) + Case ARRAYERROR ' SF_Utils._ValidateArray(Value, Name, Dimensions, Types, NotNull) + pvArgs(1) = _RightCase(pvArgs(1)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(1)) _ + & "\n" & "\n" & .GetText("VALIDATIONRULES") _ + & "\n" & .GetText("VALIDATEARRAY", pvArgs(1)) + If pvArgs(2) > 0 Then sMessage = sMessage & "\n" & .GetText("VALIDATEDIMS", pvArgs(1), pvArgs(2)) + If Len(pvArgs(3)) > 0 Then sMessage = sMessage & "\n" & .GetText("VALIDATEALLTYPES", pvArgs(1), pvArgs(3)) + If pvArgs(4) Then sMessage = sMessage & "\n" & .GetText("VALIDATENOTNULL", pvArgs(1)) + sMessage = sMessage & "\n" & "\n" & .GetText("VALIDATEACTUAL", pvArgs(1), pvArgs(0)) + Case FILEERROR ' SF_Utils._ValidateFile(Value, Name, WildCards) + pvArgs(1) = _RightCase(pvArgs(1)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(1)) _ + & "\n" & "\n" & .GetText("VALIDATIONRULES") _ + & "\n" & "\n" & .GetText("VALIDATEFILE", pvArgs(1)) + sAlt = "VALIDATEFILE" & SF_FileSystem.FileNaming + sMessage = sMessage & "\n" & .GetText(sAlt, pvArgs(1)) + If pvArgs(2) Then sMessage = sMessage & "\n" & .GetText("VALIDATEWILDCARD", pvArgs(1)) + sMessage = sMessage & "\n" & "\n" & .GetText("VALIDATEACTUAL", pvArgs(1), pvArgs(0)) + Case ARRAYSEQUENCEERROR ' SF_Array.RangeInit(From, UpTo, ByStep) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("ARRAYSEQUENCE", pvArgs(0), pvArgs(1), pvArgs(2)) + Case ARRAYINSERTERROR ' SF_Array.AppendColumn/Row/PrependColumn/Row(VectorName, Array_2D, Vector) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("ARRAYINSERT", pvArgs(0), pvArgs(1), pvArgs(2)) + Case ARRAYINDEX1ERROR ' SF_Array.ExtractColumn/Row(IndexName, Array_2D, Index) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("ARRAYINDEX1", pvArgs(0), pvArgs(1), pvArgs(2)) + Case ARRAYINDEX2ERROR ' SF_Array.Slice(From, UpTo) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("ARRAYINDEX2", pvArgs(0), pvArgs(1), pvArgs(2)) + Case CSVPARSINGERROR ' SF_Array.ImportFromCSVFile(FileName, LineNumber, Line) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("CSVPARSING", pvArgs(0), pvArgs(1), pvArgs(2)) + Case DUPLICATEKEYERROR ' SF_Dictionary.Add/ReplaceKey("Key", Key) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("DUPLICATEKEY", pvArgs(0), pvArgs(1)) + Case UNKNOWNKEYERROR ' SF_Dictionary.Remove/ReplaceItem/ReplaceKey("Key", Key) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("UNKNOWNKEY", pvArgs(0), pvArgs(1)) + Case INVALIDKEYERROR ' SF_Dictionary.Add/ReplaceKey(Key) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("INVALIDKEY") + Case UNKNOWNFILEERROR ' SF_FileSystem.CopyFile/MoveFile/DeleteFile/CreateScriptService("L10N")(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("UNKNOWNFILE", pvArgs(0), pvArgs(1)) + Case UNKNOWNFOLDERERROR ' SF_FileSystem.CopyFolder/MoveFolder/DeleteFolder/Files/SubFolders(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("UNKNOWNFOLDER", pvArgs(0), pvArgs(1)) + Case NOTAFILEERROR ' SF_FileSystem.CopyFile/MoveFile/DeleteFile(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("NOTAFILE", pvArgs(0), pvArgs(1)) + Case NOTAFOLDERERROR ' SF_FileSystem.CopyFolder/MoveFolder/DeleteFolder/Files/SubFolders(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("NOTAFOLDER", pvArgs(0), pvArgs(1)) + Case OVERWRITEERROR ' SF_FileSystem.Copy+Move/File+Folder/CreateTextFile/OpenTextFile(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("OVERWRITE", pvArgs(0), pvArgs(1)) + Case READONLYERROR ' SF_FileSystem.Copy+Move+Delete/File+Folder(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("READONLY", pvArgs(0), pvArgs(1)) + Case NOFILEMATCHERROR ' SF_FileSystem.Copy+Move+Delete/File+Folder(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("NOFILEMATCH", pvArgs(0), pvArgs(1)) + Case FOLDERCREATIONERROR ' SF_FileSystem.CreateFolder(ArgName, Filename) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("FOLDERCREATION", pvArgs(0), pvArgs(1)) + Case UNKNOWNSERVICEERROR ' SF_Services.CreateScriptService(ArgName, Value, Library, Service) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("UNKNOWNSERVICE", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case SERVICESNOTLOADEDERROR ' SF_Services.CreateScriptService(ArgName, Value, Library) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("SERVICESNOTLOADED", pvArgs(0), pvArgs(1), pvArgs(2)) + Case CALCFUNCERROR ' SF_Session.ExecuteCalcFunction(CalcFunction) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", _RightCase("CalcFunction")) _ + & "\n" & "\n" & .GetText("CALCFUNC", pvArgs(0)) + Case NOSCRIPTERROR ' SF_Session._GetScript(Language, "Scope", Scope, "Script", Script) + pvArgs(1) = _RightCase(pvArgs(1)) : pvArgs(3) = _RightCase(pvArgs(3)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", _RightCase("Script")) _ + & "\n" & "\n" & .GetText("NOSCRIPT", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4)) + Case SCRIPTEXECERROR ' SF_Session.ExecuteBasicScript("Script", Script, Cause) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("SCRIPTEXEC", pvArgs(0), pvArgs(1), pvArgs(2)) + Case WRONGEMAILERROR ' SF_Session.SendMail(Arg, Email) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("WRONGEMAIL", pvArgs(1)) + Case SENDMAILERROR ' SF_Session.SendMail() + sMessage = sLocation _ + & "\n" & "\n" & .GetText("SENDMAIL") + Case FILENOTOPENERROR ' SF_TextStream._IsFileOpen(FileName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("FILENOTOPEN", pvArgs(0)) + Case FILEOPENMODEERROR ' SF_TextStream._IsFileOpen(FileName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("FILEOPENMODE", pvArgs(0), pvArgs(1)) + Case ENDOFFILEERROR ' SF_TextStream.ReadLine/ReadAll/SkipLine(FileName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("ENDOFFILE", pvArgs(0)) + Case DOCUMENTERROR ' SF_UI.GetDocument(ArgName, WindowName) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("DOCUMENT", pvArgs(0), pvArgs(1)) + Case DOCUMENTCREATIONERROR ' SF_UI.Create(Arg1Name, DocumentType, Arg2Name, TemplateFile) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DOCUMENTCREATION", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case DOCUMENTOPENERROR ' SF_UI.OpenDocument(Arg1Name, FileName, Arg2Name, Password, Arg3Name, FilterName) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) : pvArgs(4) = _RightCase(pvArgs(4)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DOCUMENTOPEN", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4), pvArgs(5)) + Case BASEDOCUMENTOPENERROR ' SF_UI.OpenBaseDocument(Arg1Name, FileName, Arg2Name, RegistrationName) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("BASEDOCUMENTOPEN", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case DOCUMENTDEADERROR ' SF_Document._IsStillAlive(FileName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DOCUMENTDEAD", pvArgs(0)) + Case DOCUMENTSAVEERROR ' SF_Document.Save(Arg1Name, FileName) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DOCUMENTSAVE", pvArgs(0), pvArgs(1)) + Case DOCUMENTSAVEASERROR ' SF_Document.SaveAs(Arg1Name, FileName, Arg2, Overwrite, Arg3, FilterName) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) : pvArgs(4) = _RightCase(pvArgs(4)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DOCUMENTSAVEAS", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4), pvArgs(5)) + Case DOCUMENTREADONLYERROR ' SF_Document.update property("Document", FileName) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DOCUMENTREADONLY", pvArgs(0), pvArgs(1)) + Case DBCONNECTERROR ' SF_Base.GetDatabase("User", User, "Password", Password, FileName) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DBCONNECT", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4)) + Case CALCADDRESSERROR ' SF_Calc._ParseAddress(Address, "Range"/"Sheet", Scope, Document) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("CALCADDRESS" & Iif(pvArgs(0) = "Sheet", "1", "2"), pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case DUPLICATESHEETERROR ' SF_Calc.InsertSheet(arg, SheetName, Document) + pvArgs(0) = _RightCase(pvArgs(0)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("DUPLICATESHEET", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case OFFSETADDRESSERROR ' SF_Calc.RangeOffset("Range", Range, "Rows", Rows, "Columns", Columns, "Height", Height, "Width", Width, "Document, Document) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) : pvArgs(4) = _RightCase(pvArgs(4)) + pvArgs(6) = _RightCase(pvArgs(6)) : pvArgs(8) = _RightCase(pvArgs(8)) : pvArgs(10) = _RightCase(pvArgs(10)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("OFFSETADDRESS", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4) _ + , pvArgs(5), pvArgs(6), pvArgs(7), pvArgs(8), pvArgs(9), pvArgs(10), pvArgs(11)) + Case DUPLICATECHARTERROR ' SF_Calc.CreateChart(chart, ChartName, sheet, SheetName, Document, file) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & "\n" & .GetText("VALIDATEERROR", pvArgs(0)) _ + & "\n" & "\n" & .GetText("DUPLICATECHART", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4), pvArgs(5)) + Case RANGEEXPORTERROR ' SF_Calc.ExportRangeToFile(Arg1Name, FileName, Arg2, Overwrite) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("RANGEEXPORT", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case CHARTEXPORTERROR ' SF_Chart.ExportToFile(Arg1Name, FileName, Arg2, Overwrite) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("CHARTEXPORT", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case FORMDEADERROR ' SF_Form._IsStillAlive(FormName, DocumentName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("FORMDEAD", pvArgs(0), pvArgs(1)) + Case CALCFORMNOTFOUNDERROR ' SF_Calc.Forms(Index, SheetName, Document) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("CALCFORMNOTFOUND", pvArgs(0), pvArgs(1), pvArgs(2)) + Case WRITERFORMNOTFOUNDERROR ' SF_Document.Forms(Index, Document) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("WRITERFORMNOTFOUND", pvArgs(0), pvArgs(1)) + Case BASEFORMNOTFOUNDERROR ' SF_Base.Forms(Index, FormDocument, BaseDocument) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("BASEFORMNOTFOUND", pvArgs(0), pvArgs(1), pvArgs(2)) + Case SUBFORMNOTFOUNDERROR ' SF_Form.Subforms(Subform, Mainform) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("SUBFORMNOTFOUND", pvArgs(0), pvArgs(1)) + Case FORMCONTROLTYPEERROR ' SF_FormControl._SetProperty(ControlName, FormName, ControlType, Property) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("FORMCONTROLTYPE", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case DIALOGNOTFOUNDERROR ' SF_Dialog._NewDialog(Service, DialogName, WindowName) + pvArgs(0) = _RightCase(pvArgs(0)) : pvArgs(2) = _RightCase(pvArgs(2)) : pvArgs(4) = _RightCase(pvArgs(4)) + pvArgs(6) = _RightCase(pvArgs(6)) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DIALOGNOTFOUND", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3), pvArgs(4) _ + , pvArgs(5), pvArgs(6), pvArgs(7)) + Case DIALOGDEADERROR ' SF_Dialog._IsStillAlive(DialogName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DIALOGDEAD", pvArgs(0)) + Case CONTROLTYPEERROR ' SF_DialogControl._SetProperty(ControlName, DialogName, ControlType, Property) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("CONTROLTYPE", pvArgs(0), pvArgs(1), pvArgs(2), pvArgs(3)) + Case TEXTFIELDERROR ' SF_DialogControl.WriteLine(ControlName, DialogName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("TEXTFIELD", pvArgs(0), pvArgs(1)) + Case DBREADONLYERROR ' SF_Database.RunSql() + sMessage = sLocation _ + & "\n" & "\n" & .GetText("DBREADONLY", vLocation(2)) + Case SQLSYNTAXERROR ' SF_Database._ExecuteSql(SQL) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("SQLSYNTAX", pvArgs(0)) + Case PYTHONSHELLERROR ' SF_Exception.PythonShell (Python only) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("PYTHONSHELL") + Case UNITTESTLIBRARYERROR ' SFUnitTests._NewUnitTest(LibraryName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("UNITTESTLIBRARY", pvArgs(0)) + Case UNITTESTMETHODERROR ' SFUnitTests.SF_UnitTest(Method) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("UNITTESTMETHOD", pvArgs(0)) + Case Else + End Select + End With + + ' Log fatal event + _SF_._AddToConsole(sMessage) + + ' Display fatal event, if relevant (default) + If _SF_.DisplayEnabled Then + If _SF_.StopWhenError Then sMessage = sMessage & "\n" & "\n" & "\n" & L10N.GetText("STOPEXECUTION") + ' Do you need more help ? + If Len(sMethod) > 0 Then + sMessage = sMessage & "\n" & "\n" & L10N.GetText("NEEDMOREHELP", sMethod) + iButtons = MB_YESNO + MB_DEFBUTTON2 + Else + iButtons = MB_OK + End If + iMsgBox = MsgBox(SF_String.ExpandTabs(SF_String.Unescape(sMessage), cstTabSize) _ + , iButtons + MB_ICONEXCLAMATION _ + , L10N.GetText("ERRORNUMBER", ErrorCode) _ + ) + ' If more help needed ... + If iMsgBox = IDYES Then _OpenHelpInBrowser(sService, sMethod) + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + _SF_._StackReset() + If _SF_.StopWhenError Then Stop + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Exception.RaiseFatal + +REM ----------------------------------------------------------------------------- +Public Sub RaiseWarning(Optional ByVal Number As Variant _ + , Optional ByVal Source As Variant _ + , Optional ByVal Description As Variant _ + ) +''' Generate a run-time error. An error message is displayed to the user and logged +''' in the console. The execution is NOT STOPPED +''' Args: +''' Number: the error number, may be numeric or string +''' If numeric and <= 2000, it is considered a LibreOffice Basic run-time error (default = Err) +''' Source: the line where the error occurred (default = Erl) or any string describing the location of the error +''' Description: the error message to log in the console and to display to the user +''' Returns: +''' True if successful. Anyway, the execution continues +''' Examples: +''' On Local Error GoTo Catch +''' ' ... +''' Catch: +''' SF_Exception.RaiseWarning() ' Standard behaviour +''' SF_Exception.RaiseWarning(11) ' Force division by zero +''' SF_Exception.RaiseWarning("MYAPPERROR", "myFunction", "Application error") +''' SF_Exception.RaiseWarning(,, "To divide by zero is not a good idea !") + +Dim bStop As Boolean ' Alias for stop switch +Const cstThisSub = "Exception.RaiseWarning" +Const cstSubArgs = "[Number=Err], [Source=Erl], [Description]" + + ' Save Err, Erl, .. values before any On Error ... statement + SF_Exception._CaptureSystemError() + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Number) Or IsEmpty(Number) Then Number = -1 + If IsMissing(Source) Or IsEmpty(Source) Then Source = -1 + If IsMissing(Description) Or IsEmpty(Description) Then Description = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Number, "Number", Array(V_STRING, V_NUMERIC, V_EMPTY)) Then GoTo Finally + If Not SF_Utils._Validate(Source, "Source", Array(V_STRING, V_NUMERIC, V_EMPTY)) Then GoTo Finally + If Not SF_Utils._Validate(Description, "Description", V_STRING) Then GoTo Finally + End If + +Try: + bStop = _SF_.StopWhenError ' Store current value to reset it before leaving the Sub + _SF_.StopWhenError = False + SF_Exception.Raise(Number, Source, Description) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + _SF_.StopWhenError = bStop + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Exception.RaiseWarning + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Exception.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Exception.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Sub _CaptureSystemError() +''' Store system error status in system error properties +''' Called at each invocation of an error management property or method +''' Reset by SF_Exception.Clear() + + If Err > 0 And _SysNumber = 0 Then + _SysNumber = Err + _SysSource = Erl + _SysDescription = Error$ + End If + +End Sub ' ScriptForge.SF_Exception._CaptureSystemError + +REM ----------------------------------------------------------------------------- +Public Sub _CloseConsole(Optional ByRef poEvent As Object) +''' Close the console when opened in non-modal mode +''' Triggered by the CloseNonModalButton from the dlgConsole dialog + + On Local Error GoTo Finally + +Try: + With _SF_ + If Not IsNull(.ConsoleDialog) Then + If .ConsoleDialog._IsStillAlive(False) Then ' False to not raise an error + Set .ConsoleControl = .ConsoleControl.Dispose() + Set .ConsoleDialog = .ConsoleDialog.Dispose() + End If + End If + End With + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_Exception._CloseConsole + +REM ----------------------------------------------------------------------------- +Private Sub _ConsoleRefresh() +''' Reload the content of the console in the dialog +''' Needed when console first loaded or when totally or partially cleared + + With _SF_ + ' Do nothing if console inactive + If IsNull(.ConsoleDialog) Then GoTo Finally + If Not .ConsoleDialog._IsStillAlive(False) Then ' False to not generate an error when dead + Set .ConsoleControl = .ConsoleControl.Dispose() + Set .ConsoleDialog = Nothing + GoTo Finally + End If + ' Store the relevant text in the control + If IsNull(.ConsoleControl) Then Set .ConsoleControl = .ConsoleDialog.Controls(CONSOLENAME) + .ConsoleControl.Value = "" + If UBound(.ConsoleLines) >= 0 Then .ConsoleControl.WriteLine(Join(.ConsoleLines, SF_String.sfNEWLINE)) + End With + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_Exception._ConsoleRefresh + +REM ----------------------------------------------------------------------------- +Private Sub _OpenHelpInBrowser(ByVal psService As String, ByVal psMethod As String) +''' Open the help page and help anchor related to the given ScriptForge service and method + +Dim sUrl As String ' URL to open +Const cstURL = "https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_%1.html?&DbPAR=BASIC#%2" + + On Local Error GoTo Finally ' No reason to risk abort here +Try: + sUrl = SF_String.ReplaceStr(cstURL, Array("%1", "%2"), Array(LCase(psService), psMethod)) + SF_Session.OpenUrlInBrowser(sUrl) + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_Exception._OpenHelpInBrowser + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SF_Exception.get" & psProperty + + SF_Exception._CaptureSystemError() + + Select Case psProperty + Case "Description" + If _Description = "" Then _PropertyGet = _SysDescription Else _PropertyGet = _Description + Case "Number" + If IsEmpty(_Number) Then _PropertyGet = _SysNumber Else _PropertyGet = _Number + Case "Source" + If IsEmpty(_Source) Then _PropertyGet = _SysSource Else _PropertyGet = _Source + Case Else + _PropertyGet = Null + End Select + +Finally: + Exit Function +End Function ' ScriptForge.SF_Exception._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set a new value to the named property +''' Applicable only to user defined errors +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SF_Exception.set" & psProperty + _PropertySet = False + + SF_Exception._CaptureSystemError() + + ' Argument validation must be manual to preserve system error status + ' If wrong VarType then property set is ignored + Select Case psProperty + Case "Description" + If VarType(pvValue) = V_STRING Then _Description = pvValue + Case "Number" + Select Case SF_Utils._VarTypeExt(pvValue) + Case V_STRING + _Number = pvValue + Case V_NUMERIC + _Number = CLng(pvValue) + If _Number <= RUNTIMEERRORS And Len(_Description) = 0 Then _Description = Error(_Number) + Case V_EMPTY + _Number = Empty + Case Else + End Select + Case "Source" + Select Case SF_Utils._VarTypeExt(pvValue) + Case V_STRING + _Source = pvValue + Case V_NUMERIC + _Source = CLng(pvValue) + Case Else + End Select + Case Else + End Select + + _PropertySet = True + +Finally: + Exit Function +End Function ' ScriptForge.SF_Exception._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Exception instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Exception]: A readable string" + + _Repr = "[Exception]: " & _Number & " (" & _Description & ")" + +End Function ' ScriptForge.SF_Exception._Repr + +REM ----------------------------------------------------------------------------- +Private Function _RightCase(psString As String) As String +''' Return the input argument in lower case only when the procedure in execution +''' has been triggered from a Python script +''' Indeed, Python requires lower case arguments +''' Args: +''' psString: probably an identifier in ProperCase +''' Return: +''' The input argument in lower case or left unchanged depending on the execution context + +Try: + If _SF_.TriggeredByPython Then _RightCase = LCase(psString) Else _RightCase = psString + +Finally: + Exit Function +End Function ' ScriptForge.SF_Exception._RightCase + +REM ----------------------------------------------------------------------------- +Private Function _RightCaseArgs(psString As String) As String +''' Return the input argument unchanged when the execution context is Basic +''' When it is Python, the argument names are lowercased. +''' Args: +''' psString: one of the cstSubArgs strings located in each official method +''' Return: +''' The input string in which the argument names are put in lower case when called from Python scripts + +Dim sSubArgs As String ' Return value +Dim vArgs As Variant ' Input string split on the comma character +Dim sSingleArg As String ' Single vArgs item +Dim vSingleArgs As Variant ' vSingleArg split on equal sign +Dim i As Integer + +Const cstComma = "," +Const cstEqual = "=" + +Try: + If Len(psString) = 0 Then + sSubArgs = "" + ElseIf _SF_.TriggeredByPython Then + vArgs = SF_String.SplitNotQuoted(psString, cstComma, QuoteChar := """") + For i = 0 To UBound(vArgs) + sSingleArg = vArgs(i) + vSingleArgs = Split(sSingleArg, cstEqual) + vSingleArgs(0) = LCase(vSingleArgs(0)) + vArgs(i) = join(vSingleArgs, cstEqual) + Next i + sSubArgs = Join(vArgs, cstComma) + Else + sSubArgs = psString + End If + +Finally: + _RightCaseArgs = sSubArgs + Exit Function +End Function ' ScriptForge.SF_Exception._RightCaseArgs + +REM ============================================ END OF SCRIPTFORGE.SF_EXCEPTION + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_FileSystem.xba b/wizards/source/scriptforge/SF_FileSystem.xba new file mode 100644 index 000000000..39ea4888e --- /dev/null +++ b/wizards/source/scriptforge/SF_FileSystem.xba @@ -0,0 +1,2128 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_FileSystem +''' ============= +''' Class implementing the file system service +''' for common file and folder handling routines +''' Including copy and move of files and folders, with or without wildcards +''' The design choices are largely inspired by +''' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filesystemobject-object +''' The File and Folder classes have been found redundant with the current class and have not been implemented +''' The implementation is mainly based on the XSimpleFileAccess UNO interface +''' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1ucb_1_1XSimpleFileAccess.html +''' +''' Subclasses: +''' SF_TextStream +''' +''' Definitions: +''' File and folder names may be expressed either in the (preferable because portable) URL form +''' or in the more usual operating system notation (e.g. C:\... for Windows) +''' The notation, both for arguments and for returned values +''' is determined by the FileNaming property: either "URL" (default) or "SYS" +''' +''' FileName: the full name of the file including the path without any ending path separator +''' FolderName: the full name of the folder including the path and the ending path separator +''' Name: the last component of the File- or FolderName including its extension +''' BaseName: the last component of the File- or FolderName without its extension +''' NamePattern: any of the above names containing wildcards in its last component +''' Admitted wildcards are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' +''' Service invocation example: +''' Dim FSO As Variant +''' Set FSO = CreateScriptService("FileSystem") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_filesystem.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" ' Source file does not exist +Const UNKNOWNFOLDERERROR = "UNKNOWNFOLDERERROR" ' Source folder or Destination folder does not exist +Const NOTAFILEERROR = "NOTAFILEERROR" ' Destination is a folder, not a file +Const NOTAFOLDERERROR = "NOTAFOLDERERROR" ' Destination is a file, not a folder +Const OVERWRITEERROR = "OVERWRITEERROR" ' Destination can not be overwritten +Const READONLYERROR = "READONLYERROR" ' Destination has its read-only attribute set +Const NOFILEMATCHERROR = "NOFILEMATCHFOUND" ' No file matches Source containing wildcards +Const FOLDERCREATIONERROR = "FOLDERCREATIONERROR" ' FolderName is an existing folder or file + +REM ============================================================ MODULE CONSTANTS + +''' TextStream open modes +Const cstForReading = 1 +Const cstForWriting = 2 +Const cstForAppending = 8 + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_FileSystem Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ConfigFolder() As String +''' Return the configuration folder of LibreOffice + +Const cstThisSub = "FileSystem.getConfigFolder" + + SF_Utils._EnterFunction(cstThisSub) + ConfigFolder = SF_FileSystem._GetConfigFolder("user") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.ConfigFolder + +REM ----------------------------------------------------------------------------- +Property Get ExtensionsFolder() As String +''' Return the folder containing the extensions installed for the current user + +Dim oMacro As Object ' /singletons/com.sun.star.util.theMacroExpander +Const cstThisSub = "FileSystem.getExtensionsFolder" + + SF_Utils._EnterFunction(cstThisSub) + Set oMacro = SF_Utils._GetUNOService("MacroExpander") + ExtensionsFolder = SF_FileSystem._ConvertFromUrl(oMacro.ExpandMacros("$UNO_USER_PACKAGES_CACHE") & "/") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.ExtensionsFolder + +REM ----------------------------------------------------------------------------- +Property Get FileNaming() As Variant +''' Return the current files and folder notation, either "ANY", "URL" or "SYS" +''' "ANY": methods receive either URL or native file names, but always return URL file names +''' "URL": methods expect URL arguments and return URL strings (when relevant) +''' "SYS": idem but operating system notation + +Const cstThisSub = "FileSystem.getFileNaming" + SF_Utils._EnterFunction(cstThisSub) + FileNaming = _SF_.FileSystemNaming + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.FileNaming (get) + +REM ----------------------------------------------------------------------------- +Property Let FileNaming(ByVal pvNotation As Variant) +''' Set the files and folders notation: "ANY", "URL" or "SYS" + +Const cstThisSub = "FileSystem.setFileNaming" + SF_Utils._EnterFunction(cstThisSub) + If VarType(pvNotation) = V_STRING Then + Select Case UCase(pvNotation) + Case "ANY", "URL", "SYS" : _SF_.FileSystemNaming = UCase(pvNotation) + Case Else ' Unchanged + End Select + End If + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.FileNaming (let) + +REM ----------------------------------------------------------------------------- +Property Get ForAppending As Integer +''' Convenient constant (see documentation) + ForAppending = cstForAppending +End Property ' ScriptForge.SF_FileSystem.ForAppending + +REM ----------------------------------------------------------------------------- +Property Get ForReading As Integer +''' Convenient constant (see documentation) + ForReading = cstForReading +End Property ' ScriptForge.SF_FileSystem.ForReading + +REM ----------------------------------------------------------------------------- +Property Get ForWriting As Integer +''' Convenient constant (see documentation) + ForWriting = cstForWriting +End Property ' ScriptForge.SF_FileSystem.ForWriting + +REM ----------------------------------------------------------------------------- +Property Get HomeFolder() As String +''' Return the user home folder + +Const cstThisSub = "FileSystem.getHomeFolder" + + SF_Utils._EnterFunction(cstThisSub) + HomeFolder = SF_FileSystem._GetConfigFolder("home") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.HomeFolder + +REM ----------------------------------------------------------------------------- +Property Get InstallFolder() As String +''' Return the installation folder of LibreOffice + +Const cstThisSub = "FileSystem.getInstallFolder" + + SF_Utils._EnterFunction(cstThisSub) + InstallFolder = SF_FileSystem._GetConfigFolder("inst") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.InstallFolder + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_FileSystem" +End Property ' ScriptForge.SF_FileSystem.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.FileSystem" +End Property ' ScriptForge.SF_FileSystem.ServiceName + +REM ----------------------------------------------------------------------------- +Property Get TemplatesFolder() As String +''' Return the folder defined in the LibreOffice paths options as intended for templates files + +Dim sPath As String ' Template property of com.sun.star.util.PathSettings +Const cstThisSub = "FileSystem.getTemplatesFolder" + + SF_Utils._EnterFunction(cstThisSub) + sPath = SF_Utils._GetUNOService("PathSettings").Template + TemplatesFolder = SF_FileSystem._ConvertFromUrl(Split(sPath, ";")(0) & "/") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.TemplatesFolder + +REM ----------------------------------------------------------------------------- +Property Get TemporaryFolder() As String +''' Return the folder defined in the LibreOffice paths options as intended for temporary files + +Const cstThisSub = "FileSystem.getTemporaryFolder" + + SF_Utils._EnterFunction(cstThisSub) + TemporaryFolder = SF_FileSystem._GetConfigFolder("temp") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.TemporaryFolder + +REM ----------------------------------------------------------------------------- +Property Get UserTemplatesFolder() As String +''' Return the folder defined in the LibreOffice paths options as intended for User templates files + +Dim sPath As String ' Template_writable property of com.sun.star.util.PathSettings +Const cstThisSub = "FileSystem.getUserTemplatesFolder" + + SF_Utils._EnterFunction(cstThisSub) + sPath = SF_Utils._GetUNOService("PathSettings").Template_writable + UserTemplatesFolder = SF_FileSystem._ConvertFromUrl(sPath & "/") + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_FileSystem.UserTemplatesFolder + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function BuildPath(Optional ByVal FolderName As Variant _ + , Optional ByVal Name As Variant _ + ) As String +''' Combines a folder path and the name of a file and returns the combination with a valid path separator +''' Inserts an additional path separator between the foldername and the name, only if necessary +''' Args: +''' FolderName: Path with which Name is combined. Path need not specify an existing folder +''' Name: To be appended to the existing path. +''' Returns: +''' The path concatenated with the file name after insertion of a path separator, if necessary +''' Example: +''' Dim a As String +''' FSO.FileNaming = "SYS" +''' a = FSO.BuildPath("C:\Windows", "Notepad.exe") returns C:\Windows\Notepad.exe + +Dim sBuild As String ' Return value +Dim sFile As String ' Alias for Name +Const cstFileProtocol = "file:///" +Const cstThisSub = "FileSystem.BuildPath" +Const cstSubArgs = "FolderName, Name" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sBuild = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FolderName, "FolderName") Then GoTo Finally + If Not SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Finally + End If + FolderName = SF_FileSystem._ConvertToUrl(FolderName) + +Try: + ' Add separator if necessary. FolderName is now in URL notation + If Len(FolderName) > 0 Then + If Right(FolderName, 1) <> "/" Then sBuild = FolderName & "/" Else sBuild = FolderName + Else + sBuild = cstFileProtocol + End If + ' Encode the file name + sFile = ConvertToUrl(Name) + ' Some file names produce http://file.name.suffix/ + If Left(sFile, 7) = "http://" Then sFile = cstFileProtocol & Mid(sFile, 8, Len(sFile) - 8) + ' Combine both parts + If Left(sFile, Len(cstFileProtocol)) = cstFileProtocol Then sBuild = sBuild & Mid(sFile, Len(cstFileProtocol) + 1) Else sBuild = sBuild & sFile + +Finally: + BuildPath = SF_FileSystem._ConvertFromUrl(sBuild) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.BuildPath + +REM ----------------------------------------------------------------------------- +Public Function CompareFiles(Optional ByVal FileName1 As Variant _ + , Optional ByVal FileName2 As Variant _ + , Optional ByVal CompareContents As Variant _ + ) +''' Compare 2 files and return True if they seem identical +''' The comparison may be based on the file attributes, like modification time, +''' or on their contents. +''' Args: +''' FileName1: The 1st file to compare +''' FileName2: The 2nd file to compare +''' CompareContents: When True, the contents of the files are compared. Default = False +''' Returns: +''' True when the files seem identical +''' Exceptions: +''' UNKNOWNFILEERROR One of the files does not exist +''' Example: +''' FSO.FileNaming = "SYS" +''' MsgBox FSO.CompareFiles("C:\myFile1.txt", "C:\myFile2.txt", CompareContents := True) + +Dim bCompare As Boolean ' Return value +Dim sFile As String ' Alias of FileName1 and 2 +Dim iFile As Integer ' 1 or 2 +Const cstPyHelper = "$" & "_SF_FileSystem__CompareFiles" + +Const cstThisSub = "FileSystem.CompareFiles" +Const cstSubArgs = "FileName1, FileName2, [CompareContents=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCompare = False + +Check: + If IsMissing(CompareContents) Or IsEmpty(CompareContents) Then CompareContents = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName1, "FileName1", False) Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName2, "FileName2", False) Then GoTo Finally + If Not SF_Utils._Validate(CompareContents, "CompareContents", V_BOOLEAN) Then GoTo Finally + End If + ' Do the files exist ? Otherwise raise error + sFile = FileName1 : iFile = 1 + If Not SF_FileSystem.FileExists(sFile) Then GoTo CatchNotExists + sFile = FileName2 : iFile = 2 + If Not SF_FileSystem.FileExists(sFile) Then GoTo CatchNotExists + +Try: + With ScriptForge.SF_Session + bCompare = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper _ + , _ConvertFromUrl(FileName1) _ + , _ConvertFromUrl(FileName2) _ + , CompareContents) + End With + +Finally: + CompareFiles = bCompare + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName" & iFile, sFile) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.CompareFiles + +REM ----------------------------------------------------------------------------- +Public Function CopyFile(Optional ByVal Source As Variant _ + , Optional ByVal Destination As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Copies one or more files from one location to another +''' Args: +''' Source: FileName or NamePattern which can include wildcard characters, for one or more files to be copied +''' Destination: FileName where the single Source file is to be copied +''' or FolderName where the multiple files from Source are to be copied +''' If FolderName does not exist, it is created +''' Anyway, wildcard characters are not allowed in Destination +''' Overwrite: If True (default), files may be overwritten +''' CopyFile will fail if Destination has the read-only attribute set, regardless of the value of Overwrite. +''' Returns: +''' True if at least one file has been copied +''' False if an error occurred +''' An error also occurs if a source using wildcard characters doesn't match any files. +''' The method stops on the first error it encounters +''' No attempt is made to roll back or undo any changes made before an error occurs +''' Exceptions: +''' UNKNOWNFILEERROR Source does not exist +''' UNKNOWNFOLDERERROR Source folder or Destination folder does not exist +''' NOFILEMATCHERROR No file matches Source containing wildcards +''' NOTAFOLDERERROR Destination is a file, not a folder +''' NOTAFILEERROR Destination is a folder, not a file +''' OVERWRITEERROR Destination can not be overwritten +''' READONLYERROR Destination has its read-only attribute set +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.CopyFile("C:\Windows\*.*", "C:\Temp\", Overwrite := False) ' Only files are copied, subfolders are not + +Dim bCopy As Boolean ' Return value + +Const cstThisSub = "FileSystem.CopyFile" +Const cstSubArgs = "Source, Destination, [Overwrite=True]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCopy = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = True + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(Source, "Source", True) Then GoTo Finally + If Not SF_Utils._ValidateFile(Destination, "Destination", False) Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoTo Finally + End If + +Try: + bCopy = SF_FileSystem._CopyMove("CopyFile", Source, Destination, Overwrite) + +Finally: + CopyFile = bCopy + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.CopyFile + +REM ----------------------------------------------------------------------------- +Public Function CopyFolder(Optional ByVal Source As Variant _ + , Optional ByVal Destination As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Copies one or more folders from one location to another +''' Args: +''' Source: FolderName or NamePattern which can include wildcard characters, for one or more folders to be copied +''' Destination: FolderName where the single Source folder is to be copied +''' or FolderName where the multiple folders from Source are to be copied +''' If FolderName does not exist, it is created +''' Anyway, wildcard characters are not allowed in Destination +''' Overwrite: If True (default), folders and their content may be overwritten +''' CopyFile will fail if Destination has the read-only attribute set, regardless of the value of Overwrite. +''' Returns: +''' True if at least one folder has been copied +''' False if an error occurred +''' An error also occurs if a source using wildcard characters doesn't match any folders. +''' The method stops on the first error it encounters +''' No attempt is made to roll back or undo any changes made before an error occurs +''' Exceptions: +''' UNKNOWNFILEERROR Source does not exist +''' UNKNOWNFOLDERERROR Source folder or Destination folder does not exist +''' NOFILEMATCHERROR No file matches Source containing wildcards +''' NOTAFOLDERERROR Destination is a file, not a folder +''' OVERWRITEERROR Destination can not be overwritten +''' READONLYERROR Destination has its read-only attribute set +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.CopyFolder("C:\Windows\*", "C:\Temp\", Overwrite := False) + +Dim bCopy As Boolean ' Return value + +Const cstThisSub = "FileSystem.CopyFolder" +Const cstSubArgs = "Source, Destination, [Overwrite=True]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCopy = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = True + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(Source, "Source", True) Then GoTo Finally + If Not SF_Utils._ValidateFile(Destination, "Destination", False) Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoTo Finally + End If + +Try: + bCopy = SF_FileSystem._CopyMove("CopyFolder", Source, Destination, Overwrite) + +Finally: + CopyFolder = bCopy + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.CopyFolder + +REM ----------------------------------------------------------------------------- +Public Function CreateFolder(Optional ByVal FolderName As Variant) As Boolean +''' Return True if the given folder name could be created successfully +''' The parent folder does not need to exist beforehand +''' Args: +''' FolderName: a string representing the folder to create. It must not exist +''' Returns: +''' True if FolderName is a valid folder name, does not exist and creation was successful +''' False otherwise including when FolderName is a file +''' Exceptions: +''' FOLDERCREATIONERROR FolderName is an existing folder or file +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.CreateFolder("C:\NewFolder\") + +Dim bCreate As Boolean ' Return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess + +Const cstThisSub = "FileSystem.CreateFolder" +Const cstSubArgs = "FolderName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCreate = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FolderName, "FolderName") Then GoTo Finally + End If + +Try: + Set oSfa = SF_Utils._GetUnoService("FileAccess") + If SF_FileSystem.FolderExists(FolderName) Then GoTo CatchExists + If SF_FileSystem.FileExists(FolderName) Then GoTo CatchExists + oSfa.createFolder(SF_FileSystem._ConvertToUrl(FolderName)) + bCreate = True + +Finally: + CreateFolder = bCreate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchExists: + SF_Exception.RaiseFatal(FOLDERCREATIONERROR, "FolderName", FolderName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.CreateFolder + +REM ----------------------------------------------------------------------------- +Public Function CreateTextFile(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Encoding As Variant _ + ) As Object +''' Creates a specified file and returns a TextStream object that can be used to write to the file +''' Args: +''' FileName: Identifies the file to create +''' Overwrite: Boolean value that indicates if an existing file can be overwritten (default = True) +''' Encoding: The character set that should be used +''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Note that LibreOffice does not implement all existing sets +''' Default = UTF-8 +''' Returns: +''' An instance of the SF_TextStream class representing the opened file or a Null object if an error occurred +''' It doesn't check either if the given encoding is implemented in LibreOffice +''' Exceptions: +''' OVERWRITEERROR File exists, creation impossible +''' Example: +''' Dim myFile As Object +''' FSO.FileNaming = "SYS" +''' Set myFile = FSO.CreateTextFile("C:\Temp\ThisFile.txt", Overwrite := True) + +Dim oTextStream As Object ' Return value +Const cstThisSub = "FileSystem.CreateTextFile" +Const cstSubArgs = "FileName, [Overwrite=True], [Encoding=""UTF-8""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oTextStream = Nothing + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = True + If IsMissing(Encoding) Or IsEmpty(Encoding) Then Encoding = "UTF-8" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Encoding, "Encoding", V_STRING) Then GoTo Finally + End If + + With SF_FileSystem + If .FileExists(FileName) Then + If Overwrite Then .DeleteFile(FileName) Else GoTo CatchOverWrite + End If + +Try: + Set oTextStream = .OpenTextFile(FileName, .ForWriting, Create := True, Encoding := Encoding) + End With + +Finally: + Set CreateTextFile = oTextStream + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchOverWrite: + SF_Exception.RaiseFatal(OVERWRITEERROR, "FileName", FileName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.CreateTextFile + +REM ----------------------------------------------------------------------------- +Public Function DeleteFile(Optional ByVal FileName As Variant) As Boolean +''' Deletes one or more files +''' Args: +''' FileName: FileName or NamePattern which can include wildcard characters, for one or more files to be deleted +''' Returns: +''' True if at least one file has been deleted +''' False if an error occurred +''' An error also occurs if a FileName using wildcard characters doesn't match any files. +''' The method stops on the first error it encounters +''' No attempt is made to roll back or undo any changes made before an error occurs +''' Exceptions: +''' UNKNOWNFILEERROR FileName does not exist +''' NOFILEMATCHERROR No file matches FileName containing wildcards +''' NOTAFILEERROR Argument is a folder, not a file +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.DeleteFile("C:\Temp\*.*") ' Only files are deleted, subfolders are not + +Dim bDelete As Boolean ' Return value + +Const cstThisSub = "FileSystem.DeleteFile" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bDelete = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName", True) Then GoTo Finally + End If + +Try: + bDelete = SF_FileSystem._Delete("DeleteFile", FileName) + +Finally: + DeleteFile = bDelete + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.DeleteFile + +REM ----------------------------------------------------------------------------- +Public Function DeleteFolder(Optional ByVal FolderName As Variant) As Boolean +''' Deletes one or more Folders +''' Args: +''' FolderName: FolderName or NamePattern which can include wildcard characters, for one or more Folders to be deleted +''' Returns: +''' True if at least one folder has been deleted +''' False if an error occurred +''' An error also occurs if a FolderName using wildcard characters doesn't match any folders. +''' The method stops on the first error it encounters +''' No attempt is made to roll back or undo any changes made before an error occurs +''' Exceptions: +''' UNKNOWNFOLDERERROR FolderName does not exist +''' NOFILEMATCHERROR No folder matches FolderName containing wildcards +''' NOTAFOLDERERROR Argument is a file, not a folder +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.DeleteFolder("C:\Temp\*") ' Only folders are deleted, files in the parent folder are not + +Dim bDelete As Boolean ' Return value + +Const cstThisSub = "FileSystem.DeleteFolder" +Const cstSubArgs = "FolderName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bDelete = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FolderName, "FolderName", True) Then GoTo Finally + End If + +Try: + bDelete = SF_FileSystem._Delete("DeleteFolder", FolderName) + +Finally: + DeleteFolder = bDelete + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.DeleteFolder + +REM ----------------------------------------------------------------------------- +Public Function ExtensionFolder(Optional ByVal Extension As Variant) As String +''' Return the folder where the given extension is installed. The argument must +''' be in the list of extensions provided by the SF_Platform.Extensions property +''' Args: +''' Extension: a valid extension name +''' Returns: +''' The requested folder using the FileNaming notation +''' Example: +''' MsgBox FSO.ExtensionFolder("apso.python.script.organizer") + +Dim sFolder As String ' Return value +Static vExtensions As Variant ' Cached list of existing extension names +Dim oPackage As Object ' /singletons/com.sun.star.deployment.PackageInformationProvider +Const cstThisSub = "FileSystem.ExtensionFolder" +Const cstSubArgs = "Extension" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFolder = "" + +Check: + If IsEmpty(vExtensions) Then vExtensions = SF_Platform.Extensions + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Extension, "Extension", V_STRING, vExtensions) Then GoTo Finally + End If + +Try: + ' Search an individual folder + Set oPackage = SF_Utils._GetUnoService("PackageInformationProvider") + sFolder = oPackage.getPackageLocation(Extension) + +Finally: + ExtensionFolder = SF_FileSystem._ConvertFromUrl(sFolder) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.ExtensionFolder + +REM ----------------------------------------------------------------------------- +Public Function FileExists(Optional ByVal FileName As Variant) As Boolean +''' Return True if the given file exists +''' Args: +''' FileName: a string representing a file +''' Returns: +''' True if FileName is a valid File name and it exists +''' False otherwise including when FileName is a folder +''' Example: +''' FSO.FileNaming = "SYS" +''' If FSO.FileExists("C:\Notepad.exe") Then ... + +Dim bExists As Boolean ' Return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess + +Const cstThisSub = "FileSystem.FileExists" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bExists = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + FileName = SF_FileSystem._ConvertToUrl(FileName) + +Try: + Set oSfa = SF_Utils._GetUnoService("FileAccess") + bExists = oSfa.exists(FileName) And Not oSfa.isFolder(FileName) + +Finally: + FileExists = bExists + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.FileExists + +REM ----------------------------------------------------------------------------- +Public Function Files(Optional ByVal FolderName As Variant _ + , Optional ByVal Filter As Variant _ + ) As Variant +''' Return an array of the FileNames stored in the given folder. The folder must exist +''' Args: +''' FolderName: the folder to explore +''' Filter: contains wildcards ("?" and "*") to limit the list to the relevant files (default = "") +''' Returns: +''' An array of strings, each entry is the FileName of an existing file +''' Exceptions: +''' UNKNOWNFOLDERERROR Folder does not exist +''' NOTAFOLDERERROR FolderName is a file, not a folder +''' Example: +''' Dim a As Variant +''' FSO.FileNaming = "SYS" +''' a = FSO.Files("C:\Windows\") + +Dim vFiles As Variant ' Return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFolderName As String ' URL lias for FolderName +Dim sFile As String ' Single file +Dim i As Long + +Const cstThisSub = "FileSystem.Files" +Const cstSubArgs = "FolderName, [Filter=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vFiles = Array() + +Check: + If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FolderName, "FolderName") Then GoTo Finally + If Not SF_Utils._Validate(Filter, "Filter", V_STRING) Then GoTo Finally + End If + sFolderName = SF_FileSystem._ConvertToUrl(FolderName) + If SF_FileSystem.FileExists(FolderName) Then GoTo CatchFile ' Must not be a file + If Not SF_FileSystem.FolderExists(FolderName) Then GoTo CatchFolder ' Folder must exist + +Try: + ' Get files + Set oSfa = SF_Utils._GetUnoService("FileAccess") + vFiles = oSfa.getFolderContents(sFolderName, False) + ' Adjust notations + For i = 0 To UBound(vFiles) + sFile = SF_FileSystem._ConvertFromUrl(vFiles(i)) + vFiles(i) = sFile + Next i + ' Reduce list to those passing the filter + If Len(Filter) > 0 Then + For i = 0 To UBound(vFiles) + sFile = SF_FileSystem.GetName(vFiles(i)) + If Not SF_String.IsLike(sFile, Filter) Then vFiles(i) = "" + Next i + vFiles = Sf_Array.TrimArray(vFiles) + End If + +Finally: + Files = vFiles + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchFile: + SF_Exception.RaiseFatal(NOTAFOLDERERROR, "FolderName", FolderName) + GoTo Finally +CatchFolder: + SF_Exception.RaiseFatal(UNKNOWNFOLDERERROR, "FolderName", FolderName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.Files + +REM ----------------------------------------------------------------------------- +Public Function FolderExists(Optional ByVal FolderName As Variant) As Boolean +''' Return True if the given folder name exists +''' Args: +''' FolderName: a string representing a folder +''' Returns: +''' True if FolderName is a valid folder name and it exists +''' False otherwise including when FolderName is a file +''' Example: +''' FSO.FileNaming = "SYS" +''' If FSO.FolderExists("C:\") Then ... + +Dim bExists As Boolean ' Return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess + +Const cstThisSub = "FileSystem.FolderExists" +Const cstSubArgs = "FolderName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bExists = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FolderName, "FolderName") Then GoTo Finally + End If + FolderName = SF_FileSystem._ConvertToUrl(FolderName) + +Try: + Set oSfa = SF_Utils._GetUnoService("FileAccess") + bExists = oSfa.isFolder(FolderName) + +Finally: + FolderExists = bExists + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.FolderExists + +REM ----------------------------------------------------------------------------- +Public Function GetBaseName(Optional ByVal FileName As Variant) As String +''' Returns the BaseName part of the last component of a File- or FolderName, without its extension +''' The method does not check for the existence of the specified file or folder +''' Args: +''' FileName: Path and file name +''' Returns: +''' The BaseName of the given argument in native operating system format. May be empty +''' Example: +''' Dim a As String +''' FSO.FileNaming = "SYS" +''' a = FSO.GetBaseName("C:\Windows\Notepad.exe") returns Notepad + +Dim sBase As String ' Return value +Dim sExt As String ' Extension +Dim sName As String ' Last component of FileName +Dim vName As Variant ' Array of trunks of sName +Const cstThisSub = "FileSystem.GetBaseName" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sBase = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + +Try: + sName = SF_FileSystem.GetName(FileName) + If Len(sName) > 0 Then + If InStr(sName, ".") > 0 Then + vName = Split(sName, ".") + sExt = vName(UBound(vName)) + sBase = Left(sName, Len(sName) - Len(sExt) - 1) + Else + sBase = sName + End If + End If + +Finally: + GetBaseName = sBase + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetBaseName + +REM ----------------------------------------------------------------------------- +Public Function GetExtension(Optional ByVal FileName As Variant) As String +''' Returns the extension part of a File- or FolderName, without the dot (.). +''' The method does not check for the existence of the specified file or folder +''' Args: +''' FileName: Path and file name +''' Returns: +''' The extension without a leading dot. May be empty +''' Example: +''' Dim a As String +''' FSO.FileNaming = "SYS" +''' a = FSO.GetExtension("C:\Windows\Notepad.exe") returns exe + +Dim sExt As String ' Return value +Dim sName As String ' Last component of FileName +Dim vName As Variant ' Array of trunks of sName +Const cstThisSub = "FileSystem.GetExtension" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sExt = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + +Try: + sName = SF_FileSystem.GetName(FileName) + If Len(sName) > 0 And InStr(sName, ".") > 0 Then + vName = Split(sName, ".") + sExt = vName(UBound(vName)) + End If + +Finally: + GetExtension = sExt + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetExtension + +REM ----------------------------------------------------------------------------- +Public Function GetFileLen(Optional ByVal FileName As Variant) As Currency +''' Return file size in bytes with four decimals ''' +''' Args: +''' FileName: a string representing a file +''' Returns: +''' File size if FileName exists +''' Exceptions: +''' UNKNOWNFILEERROR The file does not exist of is a folder +''' Example: +''' Print SF_FileSystem.GetFileLen("C:\pagefile.sys") + +Dim curSize As Currency ' Return value +Const cstPyHelper = "$" & "_SF_FileSystem__GetFilelen" +Const cstThisSub = "FileSystem.GetFileLen" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + curSize = 0 + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + +Try: + If SF_FileSystem.FileExists(FileName) Then + With ScriptForge.SF_Session + curSize = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper _ + , _ConvertFromUrl(FileName)) + End With + Else + GoTo CatchNotExists + End If + +Finally: + GetFileLen = curSize + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetFileLen + +REM ----------------------------------------------------------------------------- +Public Function GetFileModified(Optional ByVal FileName As Variant) As Variant +''' Returns the last modified date for the given file +''' Args: +''' FileName: a string representing an existing file +''' Returns: +''' The modification date and time as a Basic Date +''' Exceptions: +''' UNKNOWNFILEERROR The file does not exist of is a folder +''' Example: +''' Dim a As Date +''' FSO.FileNaming = "SYS" +''' a = FSO.GetFileModified("C:\Temp\myDoc.odt") + +Dim dModified As Date ' Return value +Dim oModified As New com.sun.star.util.DateTime +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess + +Const cstThisSub = "FileSystem.GetFileModified" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + dModified = 0 + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + +Try: + Set oSfa = SF_Utils._GetUnoService("FileAccess") + If SF_FileSystem.FileExists(FileName) Then + FileName = SF_FileSystem._ConvertToUrl(FileName) + Set oModified = oSfa.getDateTimeModified(FileName) + dModified = CDateFromUnoDateTime(oModified) + Else + GoTo CatchNotExists + End If + +Finally: + GetFileModified = dModified + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetFileModified + +REM ----------------------------------------------------------------------------- +Public Function GetName(Optional ByVal FileName As Variant) As String +''' Returns the last component of a File- or FolderName +''' The method does not check for the existence of the specified file or folder +''' Args: +''' FileName: Path and file name +''' Returns: +''' The last component of the full file name in native operating system format +''' Example: +''' Dim a As String +''' FSO.FileNaming = "SYS" +''' a = FSO.GetName("C:\Windows\Notepad.exe") returns Notepad.exe + +Dim sName As String ' Return value +Dim vFile As Variant ' Array of components +Const cstThisSub = "FileSystem.GetName" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sName = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + FileName = SF_FileSystem._ConvertToUrl(FileName) + +Try: + If Len(FileName) > 0 Then + If Right(FileName, 1) = "/" Then FileName = Left(FileName, Len(FileName) - 1) + vFile = Split(FileName, "/") + sName = ConvertFromUrl(vFile(UBound(vFile))) ' Always in SYS format + End If + +Finally: + GetName = sName + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetName + +REM ----------------------------------------------------------------------------- +Public Function GetParentFolderName(Optional ByVal FileName As Variant) As String +''' Returns a string containing the name of the parent folder of the last component in a specified File- or FolderName +''' The method does not check for the existence of the specified file or folder +''' Args: +''' FileName: Path and file name +''' Returns: +''' A FolderName including its final path separator +''' Example: +''' Dim a As String +''' FSO.FileNaming = "SYS" +''' a = FSO.GetParentFolderName("C:\Windows\Notepad.exe") returns C:\Windows\ + +Dim sFolder As String ' Return value +Dim sName As String ' Last component of FileName +Dim vFile As Variant ' Array of file components +Const cstThisSub = "FileSystem.GetParentFolderName" +Const cstSubArgs = "FileName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFolder = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + End If + FileName = SF_FileSystem._ConvertToUrl(FileName) + +Try: + If Right(FileName, 1) = "/" Then FileName = Left(FileName, Len(FileName) - 1) + vFile = Split(FileName, "/") + If UBound(vFile) >= 0 Then vFile(UBound(vFile)) = "" + sFolder = Join(vFile, "/") + If sFolder = "" Or Right(sFolder, 1) <> "/" Then sFolder = sFolder & "/" + +Finally: + GetParentFolderName = SF_FileSystem._ConvertFromUrl(sFolder) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetParentFolderName + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "FileSystem.GetProperty" +Const cstSubArgs = "PropertyName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case UCase("ConfigFolder") : GetProperty = ConfigFolder + Case UCase("ExtensionsFolder") : GetProperty = ExtensionsFolder + Case UCase("FileNaming") : GetProperty = FileNaming + Case UCase("HomeFolder") : GetProperty = HomeFolder + Case UCase("InstallFolder") : GetProperty = InstallFolder + Case UCase("TemplatesFolder") : GetProperty = TemplatesFolder + Case UCase("TemporaryFolder") : GetProperty = TemporaryFolder + Case UCase("UserTemplatesFolder") : GetProperty = UserTemplatesFolder + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetTempName() As String +''' Returns a randomly generated temporary file name that is useful for performing +''' operations that require a temporary file : the method does not create any file +''' Args: +''' Returns: +''' A FileName as a String that can be used f.i. with CreateTextFile() +''' The FileName does not have any suffix +''' Example: +''' Dim a As String +''' FSO.FileNaming = "SYS" +''' a = FSO.GetTempName() & ".txt" + +Dim sFile As String ' Return value +Dim sTempDir As String ' The path to a temporary folder +Dim lRandom As Long ' Random integer + +Const cstThisSub = "FileSystem.GetTempName" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFile = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + lRandom = SF_Session.ExecuteCalcFunction("RANDBETWEEN", 1, 999999) + sFile = SF_FileSystem.TemporaryFolder & "SF_" & Right("000000" & lRandom, 6) + +Finally: + GetTempName = SF_FileSystem._ConvertFromUrl(sFile) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.GetTempName + +REM ----------------------------------------------------------------------------- +Public Function HashFile(Optional ByVal FileName As Variant _ + , Optional ByVal Algorithm As Variant _ + ) As String +''' Return an hexadecimal string representing a checksum of the given file +''' Next algorithms are supported: MD5, SHA1, SHA224, SHA256, SHA384 and SHA512 +''' Args: +''' FileName: a string representing a file +''' Algorithm: The hashing algorithm to use +''' Returns: +''' The requested checksum as a string. Hexadecimal digits are lower-cased +''' A zero-length string when an error occurred +''' Exceptions: +''' UNKNOWNFILEERROR The file does not exist of is a folder +''' Example: +''' Print SF_FileSystem.HashFile("C:\pagefile.sys", "MD5") + +Dim sHash As String ' Return value +Const cstPyHelper = "$" & "_SF_FileSystem__HashFile" +Const cstThisSub = "FileSystem.HashFile" +Const cstSubArgs = "FileName, Algorithm=""MD5""|""SHA1""|""SHA224""|""SHA256""|""SHA384""|""SHA512""" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sHash = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Algorithm, "Algorithm", V_STRING _ + , Array("MD5", "SHA1", "SHA224", "SHA256", "SHA384", "SHA512")) Then GoTo Finally + End If + +Try: + If SF_FileSystem.FileExists(FileName) Then + With ScriptForge.SF_Session + sHash = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper _ + , _ConvertFromUrl(FileName), LCase(Algorithm)) + End With + Else + GoTo CatchNotExists + End If + +Finally: + HashFile = sHash + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.HashFile + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list or methods of the FileSystem service as an array + + Methods = Array("BuildPath" _ + , "CompareFiles" _ + , "CopyFile" _ + , "CopyFolder" _ + , "CreateFolder" _ + , "CreateTextFile" _ + , "DeleteFile" _ + , "DeleteFolder" _ + , "ExtensionFolder" _ + , "FileExists" _ + , "Files" _ + , "FolderExists" _ + , "GetBaseName" _ + , "GetExtension" _ + , "GetFileLen" _ + , "GetFileModified" _ + , "GetName" _ + , "GetParentFolderName" _ + , "GetTempName" _ + , "HashFile" _ + , "MoveFile" _ + , "MoveFolder" _ + , "OpenTextFile" _ + , "PickFile" _ + , "PickFolder" _ + , "SubFolders" _ + ) + +End Function ' ScriptForge.SF_FileSystem.Methods + +REM ----------------------------------------------------------------------------- +Public Function MoveFile(Optional ByVal Source As Variant _ + , Optional ByVal Destination As Variant _ + ) As Boolean +''' Moves one or more files from one location to another +''' Args: +''' Source: FileName or NamePattern which can include wildcard characters, for one or more files to be moved +''' Destination: FileName where the single Source file is to be moved +''' If Source and Destination have the same parent folder MoveFile amounts to renaming the Source +''' or FolderName where the multiple files from Source are to be moved +''' If FolderName does not exist, it is created +''' Anyway, wildcard characters are not allowed in Destination +''' Returns: +''' True if at least one file has been moved +''' False if an error occurred +''' An error also occurs if a source using wildcard characters doesn't match any files. +''' The method stops on the first error it encounters +''' No attempt is made to roll back or undo any changes made before an error occurs +''' Exceptions: +''' UNKNOWNFILEERROR Source does not exist +''' UNKNOWNFOLDERERROR Source folder or Destination folder does not exist +''' NOFILEMATCHERROR No file matches Source containing wildcards +''' NOTAFOLDERERROR Destination is a file, not a folder +''' NOTAFILEERROR Destination is a folder, not a file +''' OVERWRITEERROR Destination can not be overwritten +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.MoveFile("C:\Temp1\*.*", "C:\Temp2\") ' Only files are moved, subfolders are not + +Dim bMove As Boolean ' Return value + +Const cstThisSub = "FileSystem.MoveFile" +Const cstSubArgs = "Source, Destination" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMove = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(Source, "Source", True) Then GoTo Finally + If Not SF_Utils._ValidateFile(Destination, "Destination", False) Then GoTo Finally + End If + +Try: + bMove = SF_FileSystem._CopyMove("MoveFile", Source, Destination, False) + +Finally: + MoveFile = bMove + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.MoveFile + +REM ----------------------------------------------------------------------------- +Public Function MoveFolder(Optional ByVal Source As Variant _ + , Optional ByVal Destination As Variant _ + ) As Boolean +''' Moves one or more folders from one location to another +''' Args: +''' Source: FolderName or NamePattern which can include wildcard characters, for one or more folders to be moved +''' Destination: FolderName where the single Source folder is to be moved +''' FolderName must not exist +''' or FolderName where the multiple folders from Source are to be moved +''' If FolderName does not exist, it is created +''' Anyway, wildcard characters are not allowed in Destination +''' Returns: +''' True if at least one folder has been moved +''' False if an error occurred +''' An error also occurs if a source using wildcard characters doesn't match any folders. +''' The method stops on the first error it encounters +''' No attempt is made to roll back or undo any changes made before an error occurs +''' Exceptions: +''' UNKNOWNFILEERROR Source does not exist +''' UNKNOWNFOLDERERROR Source folder or Destination folder does not exist +''' NOFILEMATCHERROR No file matches Source containing wildcards +''' NOTAFOLDERERROR Destination is a file, not a folder +''' OVERWRITEERROR Destination can not be overwritten +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.MoveFolder("C:\Temp1\*", "C:\Temp2\") + +Dim bMove As Boolean ' Return value + +Const cstThisSub = "FileSystem.MoveFolder" +Const cstSubArgs = "Source, Destination" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMove = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(Source, "Source", True) Then GoTo Finally + If Not SF_Utils._ValidateFile(Destination, "Destination", False) Then GoTo Finally + End If + +Try: + bMove = SF_FileSystem._CopyMove("MoveFolder", Source, Destination, False) + +Finally: + MoveFolder = bMove + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.MoveFolder + +REM ----------------------------------------------------------------------------- +Public Function OpenTextFile(Optional ByVal FileName As Variant _ + , Optional ByVal IOMode As Variant _ + , Optional ByVal Create As Variant _ + , Optional ByVal Encoding As Variant _ + ) As Object +''' Opens a specified file and returns a TextStream object that can be used to read from, write to, or append to the file +''' Args: +''' FileName: Identifies the file to open +''' IOMode: Indicates input/output mode. Can be one of three constants: ForReading, ForWriting, or ForAppending +''' Create: Boolean value that indicates whether a new file can be created if the specified filename doesn't exist. +''' The value is True if a new file and its parent folders may be created; False if they aren't created (default) +''' Encoding: The character set that should be used +''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Note that LibreOffice does not implement all existing sets +''' Default = UTF-8 +''' Returns: +''' An instance of the SF_TextStream class representing the opened file or a Null object if an error occurred +''' The method does not check if the file is really a text file +''' It doesn't check either if the given encoding is implemented in LibreOffice nor if it is the right one +''' Exceptions: +''' UNKNOWNFILEERROR File does not exist +''' Example: +''' Dim myFile As Object +''' FSO.FileNaming = "SYS" +''' Set myFile = FSO.OpenTextFile("C:\Temp\ThisFile.txt", FSO.ForReading) +''' If Not IsNull(myFile) Then ' ... Go ahead with reading text lines + +Dim oTextStream As Object ' Return value +Dim bExists As Boolean ' File to open does exist +Const cstThisSub = "FileSystem.OpenTextFile" +Const cstSubArgs = "FileName, [IOMode=1], [Create=False], [Encoding=""UTF-8""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oTextStream = Nothing + +Check: + With SF_FileSystem + If IsMissing(IOMode) Or IsEmpty(IOMode) Then IOMode = ForReading + If IsMissing(Create) Or IsEmpty(Create) Then Create = False + If IsMissing(Encoding) Or IsEmpty(Encoding) Then Encoding = "UTF-8" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(IOMode, "IOMode", V_NUMERIC _ + , Array(ForReading, ForWriting, ForAppending)) _ + Then GoTo Finally + If Not SF_Utils._Validate(Create, "Create", V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Encoding, "Encoding", V_STRING) Then GoTo Finally + End If + + bExists = .FileExists(FileName) + Select Case IOMode + Case ForReading : If Not bExists Then GoTo CatchNotExists + Case Else : If Not bExists And Not Create Then GoTo CatchNotExists + End Select + + If IOMode = ForAppending And Not bExists Then IOMode = ForWriting + End With + +Try: + ' Create and initialize TextStream class instance + Set oTextStream = New SF_TextStream + With oTextStream + .[Me] = oTextStream + .[_Parent] = SF_FileSystem + ._FileName = SF_FileSystem._ConvertToUrl(FileName) + ._IOMode = IOMode + ._Encoding = Encoding + ._FileExists = bExists + ._Initialize() + End With + +Finally: + Set OpenTextFile = oTextStream + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.OpenTextFile + +REM ----------------------------------------------------------------------------- +Public Function PickFile(Optional ByVal DefaultFile As Variant _ + , Optional ByVal Mode As Variant _ + , Optional ByVal Filter As Variant _ + ) As String +''' Returns the file selected with a FilePicker dialog box +''' The mode, OPEN or SAVE, and the filter may be preset +''' If mode = SAVE and the picked file exists, a warning message will be displayed +''' Modified from Andrew Pitonyak's Base Macro Programming §10.4 +''' Args: +''' DefaultFile: Folder part: the FolderName from which to start. Default = the last selected folder +''' File part: the default file to open or save +''' Mode: "OPEN" (input file) or "SAVE" (output file) +''' Filter: by default only files having the given suffix will be displayed. Default = all suffixes +''' The filter combo box will contain the given SuffixFilter (if not "*") and "*.*" +''' Returns: +''' The selected FileName in URL format or "" if the dialog was cancelled +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.PickFile("C:\", "OPEN", "txt") ' Only *.txt files are displayed + +Dim oFileDialog As Object ' com.sun.star.ui.dialogs.FilePicker +Dim oFileAccess As object ' com.sun.star.ucb.SimpleFileAccess +Dim oPath As Object ' com.sun.star.util.PathSettings +Dim iAccept As Integer ' Result of dialog execution +Dim sInitPath As String ' Current working directory +Dim sBaseFile As String +Dim iMode As Integer ' Numeric alias for SelectMode +Dim sFile As String ' Return value + +Const cstThisSub = "FileSystem.PickFile" +Const cstSubArgs = "[DefaultFile=""""], [Mode=""OPEN""|""SAVE""],[Filter=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFile = "" + +Check: + If IsMissing(DefaultFile) Or IsEmpty(DefaultFile) Then DefaultFile = "" + If IsMissing(Mode) Or IsEmpty(Mode) Then Mode = "OPEN" + If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(DefaultFile, "DefaultFile", , True) Then GoTo Finally + If Not SF_Utils._Validate(Mode, "Mode", V_STRING, Array("OPEN", "SAVE")) Then GoTo Finally + If Not SF_Utils._Validate(Filter, "Filter", V_STRING) Then GoTo Finally + End If + DefaultFile = SF_FileSystem._ConvertToUrl(DefaultFile) + +Try: + ' Derive numeric equivalent of the Mode argument: https://api.libreoffice.org/docs/idl/ref/TemplateDescription_8idl.html + With com.sun.star.ui.dialogs.TemplateDescription + If Mode = "OPEN" Then iMode = .FILEOPEN_SIMPLE Else iMode = .FILESAVE_AUTOEXTENSION + End With + + ' Activate the filepicker dialog + Set oFileDialog = SF_Utils._GetUNOService("FilePicker") + With oFileDialog + .Initialize(Array(iMode)) + + ' Set filters + If Len(Filter) > 0 Then .appendFilter("*." & Filter, "*." & Filter) ' Twice: required by API + .appendFilter("*.*", "*.*") + If Len(Filter) > 0 Then .setCurrentFilter("*." & Filter) Else .setCurrentFilter("*.*") + + ' Set initial folder + If Len(DefaultFile) = 0 Then ' TODO: SF_Session.WorkingFolder + Set oPath = SF_Utils._GetUNOService("PathSettings") + sInitPath = oPath.Work ' Probably My Documents + Else + sInitPath = SF_FileSystem._ParseUrl(ConvertToUrl(DefaultFile)).Path + End If + + ' Set default values + Set oFileAccess = SF_Utils._GetUNOService("FileAccess") + If oFileAccess.exists(sInitPath) Then .SetDisplayDirectory(sInitPath) + sBaseFile = SF_FileSystem.GetName(DefaultFile) + .setDefaultName(sBaseFile) + + ' Get selected file + iAccept = .Execute() + If iAccept = com.sun.star.ui.dialogs.ExecutableDialogResults.OK Then sFile = .getSelectedFiles()(0) + End With + +Finally: + PickFile = SF_FileSystem._ConvertFromUrl(sFile) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.PickFile + +REM ----------------------------------------------------------------------------- +Public Function PickFolder(Optional ByVal DefaultFolder As Variant _ + , Optional ByVal FreeText As Variant _ + ) As String +''' Display a FolderPicker dialog box +''' Args: +''' DefaultFolder: the FolderName from which to start. Default = the last selected folder +''' FreeText: text to display in the dialog. Default = "" +''' Returns: +''' The selected FolderName in URL or operating system format +''' The zero-length string if the dialog was cancelled +''' Example: +''' FSO.FileNaming = "SYS" +''' FSO.PickFolder("C:\", "Choose a folder or press Cancel") + +Dim oFolderDialog As Object ' com.sun.star.ui.dialogs.FolderPicker +Dim iAccept As Integer ' Value returned by the dialog (OK, Cancel, ..) +Dim sFolder As String ' Return value ' + +Const cstThisSub = "FileSystem.PickFolder" +Const cstSubArgs = "[DefaultFolder=""""], [FreeText=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFolder = "" + +Check: + If IsMissing(DefaultFolder) Or IsEmpty(DefaultFolder) Then DefaultFolder = "" + If IsMissing(FreeText) Or IsEmpty(FreeText) Then FreeText = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(DefaultFolder, "DefaultFolder", , True) Then GoTo Finally + If Not SF_Utils._Validate(FreeText, "FreeText", V_STRING) Then GoTo Finally + End If + DefaultFolder = SF_FileSystem._ConvertToUrl(DefaultFolder) + +Try: + Set oFolderDialog = SF_Utils._GetUNOService("FolderPicker") + If Not IsNull(oFolderDialog) Then + With oFolderDialog + If Len(DefaultFolder) > 0 Then .DisplayDirectory = ConvertToUrl(DefaultFolder) + .Description = FreeText + iAccept = .Execute() + ' https://api.libreoffice.org/docs/idl/ref/ExecutableDialogResults_8idl.html + If iAccept = com.sun.star.ui.dialogs.ExecutableDialogResults.OK Then + .DisplayDirectory = .Directory ' Set the next default initial folder to the selected one + sFolder = .Directory & "/" + End If + End With + End If + +Finally: + PickFolder = SF_FileSystem._ConvertFromUrl(sFolder) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.PickFolder + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the FileSystem module as an array + + Properties = Array( _ + "ConfigFolder" _ + , "ExtensionsFolder" _ + , "FileNaming" _ + , "HomeFolder" _ + , "InstallFolder" _ + , "TemplatesFolder" _ + , "TemporaryFolder" _ + , "UserTemplatesFolder" _ + ) + +End Function ' ScriptForge.SF_FileSystem.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "FileSystem.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case UCase("FileNaming") : FileNaming = Value + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SubFolders(Optional ByVal FolderName As Variant _ + , Optional ByVal Filter As Variant _ + ) As Variant +''' Return an array of the FolderNames stored in the given folder. The folder must exist +''' Args: +''' FolderName: the folder to explore +''' Filter: contains wildcards ("?" and "*") to limit the list to the relevant folders (default = "") +''' Returns: +''' An array of strings, each entry is the FolderName of an existing folder +''' Exceptions: +''' UNKNOWNFOLDERERROR Folder does not exist +''' NOTAFOLDERERROR FolderName is a file, not a folder +''' Example: +''' Dim a As Variant +''' FSO.FileNaming = "SYS" +''' a = FSO.SubFolders("C:\Windows\") + +Dim vSubFolders As Variant ' Return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFolderName As String ' URL lias for FolderName +Dim sFolder As String ' Single folder +Dim i As Long + +Const cstThisSub = "FileSystem.SubFolders" +Const cstSubArgs = "FolderName, [Filter=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSubFolders = Array() + +Check: + If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FolderName, "FolderName") Then GoTo Finally + If Not SF_Utils._Validate(Filter, "Filter", V_STRING) Then GoTo Finally + End If + sFolderName = SF_FileSystem._ConvertToUrl(FolderName) + If SF_FileSystem.FileExists(FolderName) Then GoTo CatchFile ' Must not be a file + If Not SF_FileSystem.FolderExists(FolderName) Then GoTo CatchFolder ' Folder must exist + +Try: + ' Get SubFolders + Set oSfa = SF_Utils._GetUnoService("FileAccess") + vSubFolders = oSfa.getFolderContents(sFolderName, True) + ' List includes files; remove them or adjust notations of folders + For i = 0 To UBound(vSubFolders) + sFolder = SF_FileSystem._ConvertFromUrl(vSubFolders(i) & "/") + If SF_FileSystem.FileExists(sFolder) Then vSubFolders(i) = "" Else vSubFolders(i) = sFolder + ' Reduce list to those passing the filter + If Len(Filter) > 0 And Len(vSubFolders(i)) > 0 Then + sFolder = SF_FileSystem.GetName(vSubFolders(i)) + If Not SF_String.IsLike(sFolder, Filter) Then vSubFolders(i) = "" + End If + Next i + vSubFolders = SF_Array.TrimArray(vSubFolders) + +Finally: + SubFolders = vSubFolders + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchFile: + SF_Exception.RaiseFatal(NOTAFOLDERERROR, "FolderName", FolderName) + GoTo Finally +CatchFolder: + SF_Exception.RaiseFatal(UNKNOWNFOLDERERROR, "FolderName", FolderName) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem.SubFolders + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _ConvertFromUrl(psFile) As String +''' Execute the builtin ConvertFromUrl function only when relevant +''' i.e. when FileNaming (how arguments and return values are provided) = "SYS" +''' Called at the bottom of methods returning file names +''' Remark: psFile might contain wildcards + +Const cstQuestion = "$QUESTION$", cstStar = "$STAR$" ' Special tokens to replace wildcards + + If SF_FileSystem.FileNaming = "SYS" Then + _ConvertFromUrl = Replace(Replace( _ + ConvertFromUrl(Replace(Replace(psFile, "?", cstQuestion), "*", cstStar)) _ + , cstQuestion, "?"), cstStar, "*") + Else + _ConvertFromUrl = psFile + End If + +End Function ' ScriptForge.FileSystem._ConvertFromUrl + +REM ----------------------------------------------------------------------------- +Private Function _ConvertToUrl(psFile) As String +''' Execute the builtin ConvertToUrl function only when relevant +''' i.e. when FileNaming (how arguments and return values are provided) = "SYS" +''' Called at the top of methods receiving file names as arguments +''' Remark: psFile might contain wildcards + + If SF_FileSystem.FileNaming = "URL" Then + _ConvertToUrl = psFile + Else + ' ConvertToUrl encodes "?" + _ConvertToUrl = Replace(ConvertToUrl(psFile), "%3F", "?") + End If + +End Function ' ScriptForge.FileSystem._ConvertToUrl + +REM ----------------------------------------------------------------------------- +Private Function _CopyMove(psMethod As String _ + , psSource As String _ + , psDestination As String _ + , pbOverWrite As Boolean _ + ) As Boolean +''' Checks the arguments and executes the given method +''' Args: +''' psMethod: CopyFile/CopyFolder or MoveFile/MoveFolder +''' psSource: Either File/FolderName +''' or NamePattern which can include wildcard characters, for one or more files/folders to be copied +''' psDestination: FileName or FolderName for copy/move of a single file/folder +''' Otherwise a destination FolderName. If it does not exist, it is created +''' pbOverWrite: If True, files/folders may be overwritten +''' Must be False for Move operations +''' Next checks are done: +''' With wildcards (multiple files/folders): +''' - Parent folder of source must exist +''' - Destination must not be a file +''' - Parent folder of Destination must exist +''' - If the Destination folder does not exist a new folder is created, +''' - At least one file matches the wildcards expression +''' - Destination files/folder must not exist if pbOverWrite = False +''' - Destination files/folders must not have the read-only attribute set +''' - Destination files must not be folders, destination folders must not be files +''' Without wildcards (single file/folder): +''' - Source file/folder must exist and be a file/folder +''' - Parent folder of Destination must exist +''' - Destination must not be an existing folder/file +''' - Destination file/folder must not exist if pbOverWrite = False +''' - Destination file must not have the read-only attribute set + +Dim bCopyMove As Boolean ' Return value +Dim bCopy As Boolean ' True if Copy, False if Move +Dim bFile As Boolean ' True if File, False if Folder +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim bWildCards As Boolean ' True if wildcards found in Source +Dim bCreateFolder As Boolean ' True when the destination folder should be created +Dim bDestExists As Boolean ' True if destination exists +Dim sSourceUrl As String ' Alias for Source +Dim sDestinationUrl As String ' Alias for Destination +Dim sDestinationFile As String ' Destination FileName +Dim sParentFolder As String ' Parent folder of Source +Dim vFiles As Variant ' Array of candidates for copy/move +Dim sFile As String ' Single file/folder +Dim sName As String ' Name (last component) of file +Dim i As Long + + ' Error handling left to calling routine + bCopyMove = False + bCopy = ( Left(psMethod, 4) = "Copy" ) + bFile = ( Right(psMethod, 4) = "File" ) + bWildCards = ( InStr(psSource, "*") + InStr(psSource, "?") + InStr(psSource, "%3F") > 0 ) 'ConvertToUrl() converts sometimes "?" to "%3F" + bDestExists = False + + With SF_FileSystem + +Check: + If bWildCards Then + sParentFolder = .GetParentFolderName(psSource) + If Not .FolderExists(sParentFolder) Then GoTo CatchNoMatch + If .FileExists(psDestination) Then GoTo CatchFileNotFolder + If Not .FolderExists(.GetParentFolderName(psDestination)) Then GoTo CatchDestFolderNotExists + bCreateFolder = Not .FolderExists(psDestination) + Else + Select Case bFile + Case True ' File + If Not .FileExists(psSource) Then GoTo CatchFileNotExists + If Not .FolderExists(.GetParentFolderName(psDestination)) Then GoTo CatchSourceFolderNotExists + If .FolderExists(psDestination) Then GoTo CatchFolderNotFile + bDestExists = .FileExists(psDestination) + If pbOverWrite = False And bDestExists = True Then GoTo CatchDestinationExists + bCreateFolder = False + Case False ' Folder + If Not .FolderExists(psSource) Then GoTo CatchSourceFolderNotExists + If Not .FolderExists(.GetParentFolderName(psDestination)) Then GoTo CatchDestFolderNotExists + If .FileExists(psDestination) Then GoTo CatchFileNotFolder + bDestExists = .FolderExists(psDestination) + If pbOverWrite = False And bDestExists Then GoTo CatchDestinationExists + bCreateFolder = Not bDestExists + End Select + End If + +Try: + Set oSfa = SF_Utils._GetUnoService("FileAccess") + If bWildCards Then + If bFile Then vFiles = .Files(sParentFolder, .GetName(psSource)) Else vFiles = .SubFolders(sParentFolder, .GetName(psSource)) + If UBound(vFiles) < 0 Then GoTo CatchNoMatch + ' Go through the candidates + If bCreateFolder Then .CreateFolder(psDestination) + For i = 0 To UBound(vFiles) + sFile = vFiles(i) + sDestinationFile = .BuildPath(psDestination, .GetName(sFile)) + If bFile Then bDestExists = .FileExists(sDestinationFile) Else bDestExists = .FolderExists(sDestinationFile) + If pbOverWrite = False Then + If bDestExists Then GoTo CatchDestinationExists + If .FolderExists(sDestinationFile) Then GoTo CatchDestinationExists + End If + sSourceUrl = ._ConvertToUrl(sFile) + sDestinationUrl = ._ConvertToUrl(sDestinationFile) + If bDestExists Then + If oSfa.isReadOnly(sDestinationUrl) Then GoTo CatchDestinationReadOnly + End If + Select Case bCopy + Case True : oSfa.copy(sSourceUrl, sDestinationUrl) + Case False : oSfa.move(sSourceUrl, sDestinationUrl) + End Select + Next i + Else + sSourceUrl = ._ConvertToUrl(psSource) + sDestinationUrl = ._ConvertToUrl(psDestination) + If bDestExists Then + If oSfa.isReadOnly(sDestinationUrl) Then GoTo CatchDestinationReadOnly + End If + If bCreateFolder Then .CreateFolder(psDestination) + Select Case bCopy + Case True : oSfa.copy(sSourceUrl, sDestinationUrl) + Case False : oSfa.move(sSourceUrl, sDestinationUrl) + End Select + End If + + End With + + bCopyMove = True + +Finally: + _CopyMove = bCopyMove + Exit Function +CatchFileNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "Source", psSource) + GoTo Finally +CatchSourceFolderNotExists: + SF_Exception.RaiseFatal(UNKNOWNFOLDERERROR, "Source", psSource) + GoTo Finally +CatchDestFolderNotExists: + SF_Exception.RaiseFatal(UNKNOWNFOLDERERROR, "Destination", psDestination) + GoTo Finally +CatchFolderNotFile: + SF_Exception.RaiseFatal(NOTAFILEERROR, "Destination", psDestination) + GoTo Finally +CatchDestinationExists: + SF_Exception.RaiseFatal(OVERWRITEERROR, "Destination", psDestination) + GoTo Finally +CatchNoMatch: + SF_Exception.RaiseFatal(NOFILEMATCHERROR, "Source", psSource) + GoTo Finally +CatchFileNotFolder: + SF_Exception.RaiseFatal(NOTAFOLDERERROR, "Destination", psDestination) + GoTo Finally +CatchDestinationReadOnly: + SF_Exception.RaiseFatal(READONLYERROR, "Destination", Iif(bWildCards, sDestinationFile, psDestination)) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem._CopyMove + +REM ----------------------------------------------------------------------------- +Public Function _CountTextLines(ByVal psFileName As String _ + , Optional ByVal pbIncludeBlanks As Boolean _ + ) As Long +''' Convenient function to count the number of lines in a textfile +''' Args: +''' psFileName: the file in FileNaming notation +''' pbIncludeBlanks: if True (default), zero-length lines are included +''' Returns: +''' The number of lines, f.i. to ease array sizing. -1 if file reading error + +Dim lLines As Long ' Return value +Dim oFile As Object ' File handler +Dim sLine As String ' The last line read + +Try: + lLines = 0 + If IsMissing(pbIncludeBlanks) Then pbIncludeBlanks = True + Set oFile = SF_FileSystem.OpenTextFile(psFileName, ForReading) + With oFile + If Not IsNull(oFile) Then + Do While Not .AtEndOfStream + sLine = .ReadLine() + lLines = lLines + Iif(Len(sLine) > 0 Or pbIncludeBlanks, 1, 0) + Loop + End If + .CloseFile() + Set oFile = .Dispose() + End With + +Finally: + _CountTextLines = lLines + Exit Function +End Function ' ScriptForge.SF_FileSystem._CountTextLines + +REM ----------------------------------------------------------------------------- +Private Function _Delete(psMethod As String _ + , psFile As String _ + ) As Boolean +''' Checks the argument and executes the given psMethod +''' Args: +''' psMethod: CopyFile/CopyFolder or MoveFile/MoveFolder +''' psFile: Either File/FolderName +''' or NamePattern which can include wildcard characters, for one or more files/folders to be deleted +''' Next checks are done: +''' With wildcards (multiple files/folders): +''' - Parent folder of File must exist +''' - At least one file matches the wildcards expression +''' - Files or folders to delete must not have the read-only attribute set +''' Without wildcards (single file/folder): +''' - File/folder must exist and be a file/folder +''' - A file or folder to delete must not have the read-only attribute set + +Dim bDelete As Boolean ' Return value +Dim bFile As Boolean ' True if File, False if Folder +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim bWildCards As Boolean ' True if wildcards found in File +Dim sFileUrl As String ' Alias for File +Dim sParentFolder As String ' Parent folder of File +Dim vFiles As Variant ' Array of candidates for deletion +Dim sFile As String ' Single file/folder +Dim sName As String ' Name (last component) of file +Dim i As Long + + ' Error handling left to calling routine + bDelete = False + bFile = ( Right(psMethod, 4) = "File" ) + bWildCards = ( InStr(psFile, "*") + InStr(psFile, "?") + InStr(psFile, "%3F") > 0 ) 'ConvertToUrl() converts sometimes "?" to "%3F" + + With SF_FileSystem + +Check: + If bWildCards Then + sParentFolder = .GetParentFolderName(psFile) + If Not .FolderExists(sParentFolder) Then GoTo CatchNoMatch + Else + Select Case bFile + Case True ' File + If .FolderExists(psFile) Then GoTo CatchFolderNotFile + If Not .FileExists(psFile) Then GoTo CatchFileNotExists + Case False ' Folder + If .FileExists(psFile) Then GoTo CatchFileNotFolder + If Not .FolderExists(psFile) Then GoTo CatchFolderNotExists + End Select + End If + +Try: + Set oSfa = SF_Utils._GetUnoService("FileAccess") + If bWildCards Then + If bFile Then vFiles = .Files(sParentFolder) Else vFiles = .SubFolders(sParentFolder) + ' Select candidates + For i = 0 To UBound(vFiles) + If Not SF_String.IsLike(.GetName(vFiles(i)), .GetName(psFile)) Then vFiles(i) = "" + Next i + vFiles = SF_Array.TrimArray(vFiles) + If UBound(vFiles) < 0 Then GoTo CatchNoMatch + ' Go through the candidates + For i = 0 To UBound(vFiles) + sFile = vFiles(i) + sFileUrl = ._ConvertToUrl(sFile) + If oSfa.isReadOnly(sFileUrl) Then GoTo CatchReadOnly + oSfa.kill(sFileUrl) + Next i + Else + sFileUrl = ._ConvertToUrl(psFile) + If oSfa.isReadOnly(sFileUrl) Then GoTo CatchReadOnly + oSfa.kill(sFileUrl) + End If + + End With + + bDelete = True + +Finally: + _Delete = bDelete + Exit Function +CatchFolderNotExists: + SF_Exception.RaiseFatal(UNKNOWNFOLDERERROR, "FolderName", psFile) + GoTo Finally +CatchFileNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", psFile) + GoTo Finally +CatchFolderNotFile: + SF_Exception.RaiseFatal(NOTAFILEERROR, "FileName", psFile) + GoTo Finally +CatchNoMatch: + SF_Exception.RaiseFatal(NOFILEMATCHERROR, Iif(bFile, "FileName", "FolderName"), psFile) + GoTo Finally +CatchFileNotFolder: + SF_Exception.RaiseFatal(NOTAFOLDERERROR, "FolderName", psFile) + GoTo Finally +CatchReadOnly: + SF_Exception.RaiseFatal(READONLYERROR, Iif(bFile, "FileName", "FolderName"), Iif(bWildCards, sFile, psFile)) + GoTo Finally +End Function ' ScriptForge.SF_FileSystem._Delete + +REM ----------------------------------------------------------------------------- +Private Function _GetConfigFolder(ByVal psFolder As String) As String +''' Returns one of next configuration folders: see https://api.libreoffice.org/docs/idl/ref/servicecom_1_1sun_1_1star_1_1util_1_1PathSubstitution.html +''' inst => Installation path of LibreOffice +''' prog => Program path of LibreOffice +''' user => The user installation/config directory +''' work => The work directory of the user. Under Windows this would be the "MyDocuments" subdirectory. Under Unix this would be the home-directory +''' home => The home directory of the user. Under Unix this would be the home- directory. +''' Under Windows this would be the CSIDL_PERSONAL directory, for example "Documents and Settings\<username>\Documents" +''' temp => The current temporary directory + +Dim oSubst As Object ' com.sun.star.util.PathSubstitution +Dim sConfig As String ' Return value + + sConfig = "" + Set oSubst = SF_Utils._GetUNOService("PathSubstitution") + If Not IsNull(oSubst) Then sConfig = oSubst.getSubstituteVariableValue("$(" & psFolder & ")") & "/" + + _GetConfigFolder = SF_FileSystem._ConvertFromUrl(sConfig) + +End Function ' ScriptForge.FileSystem._GetConfigFolder + +REM ----------------------------------------------------------------------------- +Public Function _ParseUrl(psUrl As String) As Object +''' Returns a com.sun.star.util.URL structure based on the argument + +Dim oParse As Object ' com.sun.star.util.URLTransformer +Dim bParsed As Boolean ' True if parsing is successful +Dim oUrl As New com.sun.star.util.URL ' Return value + + oUrl.Complete = psUrl + Set oParse = SF_Utils._GetUNOService("URLTransformer") + bParsed = oParse.parseStrict(oUrl, "") + If bParsed Then oUrl.Path = ConvertToUrl(oUrl.Path) + + Set _ParseUrl = oUrl + +End Function ' ScriptForge.SF_FileSystem._ParseUrl + +REM ----------------------------------------------------------------------------- +Public Function _SFInstallFolder() As String +''' Returns the installation folder of the ScriptForge library +''' Either: +''' - The library is present in [My Macros & Dialogs] +''' ($config)/basic/ScriptForge +''' - The library is present in [LibreOffice Macros & Dialogs] +''' ($install)/share/basic/ScriptForge + +Dim sFolder As String ' Folder + + _SFInstallFolder = "" + + sFolder = BuildPath(ConfigFolder, "basic/ScriptForge") + If Not FolderExists(sFolder) Then + sFolder = BuildPath(InstallFolder, "share/basic/ScriptForge") + If Not FolderExists(sFolder) Then Exit Function + End If + + _SFInstallFolder = _ConvertFromUrl(sFolder) + +End Function ' ScriptForge.SF_FileSystem._SFInstallFolder + +REM ============================================ END OF SCRIPTFORGE.SF_FileSystem + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_L10N.xba b/wizards/source/scriptforge/SF_L10N.xba new file mode 100644 index 000000000..6bc6b236f --- /dev/null +++ b/wizards/source/scriptforge/SF_L10N.xba @@ -0,0 +1,825 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule +'Option Private Module + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' L10N (aka SF_L10N) +''' ==== +''' Implementation of a Basic class for providing a number of services +''' related to the translation of user interfaces into a huge number of languages +''' with a minimal impact on the program code itself +''' +''' The design choices of this module are based on so-called PO-files +''' PO-files (portable object files) have long been promoted in the free software industry +''' as a mean of providing multilingual UIs. This is accomplished through the use of human-readable +''' text files with a well defined structure that specifies, for any given language, +''' the source language string and the localized string +''' +''' To read more about the PO format and its ecosystem of associated toolsets: +''' https://www.gnu.org/software/gettext/manual/html_node/PO-Files.html#PO-Files +''' and, IMHO, a very good tutorial: +''' http://pology.nedohodnik.net/doc/user/en_US/ch-about.html +''' +''' The main advantage of the PO format is the complete dissociation between the two +''' very different profiles, i.e. the programmer and the translator(s). +''' Being independent text files, one per language to support, the programmer may give away +''' pristine PO template files (known as POT-files) for a translator to process. +''' +''' This class implements mainly 4 mechanisms: +''' 1. AddText: for the programmer to build a set of words or sentences +''' meant for being translated later +''' 2. AddTextsFromDialog: to automatically execute AddText() on each fixed text of a dialog +''' 3. ExportToPOTFile: All the above texts are exported into a pristine POT-file +''' 4. GetText: At runtime get the text in the user language +''' Note that the first two are optional: POT and PO-files may be built with a simple text editor +''' +''' Several instances of the L10N class may coexist +' The constraint however is that each instance should find its PO-files +''' in a separate directory +''' PO-files must be named with the targeted locale: f.i. "en-US.po" or "fr-BE.po" +''' +''' Service invocation syntax +''' CreateScriptService("L10N"[, FolderName[, Locale]]) +''' FolderName: the folder containing the PO-files (in SF_FileSystem.FileNaming notation) +''' Locale: in the form la-CO (language-COUNTRY) +''' Encoding: The character set that should be used (default = UTF-8) +''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Locale2: fallback Locale to select if Locale po file does not exist (typically "en-US") +''' Encoding2: Encoding of the 2nd Locale file +''' Service invocation examples: +''' Dim myPO As Variant +''' myPO = CreateScriptService("L10N") ' AddText, AddTextsFromDialog and ExportToPOTFile are allowed +''' myPO = CreateScriptService("L10N", "C:\myPOFiles\", "fr-BE") +''' 'All functionalities are available +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_l10n.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM =============================================================== PRIVATE TYPES + +''' The recognized elements of an entry in a PO file are (other elements are ignored) : +''' #. Extracted comments (given by the programmer to the translator) +''' #, flag (the kde-format flag when the string contains tokens) +''' msgctxt Context (to store an acronym associated with the message, this is a distortion of the norm) +''' msgid untranslated-string +''' msgstr translated-string +''' NB: plural forms are not supported + +Type POEntry + Comment As String + Flag As String + Context As String + MsgId As String + MsgStr As String +End Type + +REM ================================================================== EXCEPTIONS + +Const DUPLICATEKEYERROR = "DUPLICATEKEYERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "L10N" +Private ServiceName As String +Private _POFolder As String ' PO files container +Private _Locale As String ' la-CO +Private _POFile As String ' PO file in URL format +Private _Encoding As String ' Used to open the PO file, default = UTF-8 +Private _Dictionary As Object ' SF_Dictionary + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "L10N" + ServiceName = "ScriptForge.L10N" + _POFolder = "" + _Locale = "" + _POFile = "" + Set _Dictionary = Nothing +End Sub ' ScriptForge.SF_L10N Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + + If Not IsNull(_Dictionary) Then Set _Dictionary = _Dictionary.Dispose() + Call Class_Initialize() +End Sub ' ScriptForge.SF_L10N Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' ScriptForge.SF_L10N Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Folder() As String +''' Returns the FolderName containing the PO-files expressed as given by the current FileNaming +''' property of the SF_FileSystem service. Default = URL format +''' May be empty +''' Example: +''' myPO.Folder + + Folder = _PropertyGet("Folder") + +End Property ' ScriptForge.SF_L10N.Folder + +REM ----------------------------------------------------------------------------- +Property Get Languages() As Variant +''' Returns a zero-based array listing all the BaseNames of the PO-files found in Folder, +''' Example: +''' myPO.Languages + + Languages = _PropertyGet("Languages") + +End Property ' ScriptForge.SF_L10N.Languages + +REM ----------------------------------------------------------------------------- +Property Get Locale() As String +''' Returns the currently active language-COUNTRY combination. May be empty +''' Example: +''' myPO.Locale + + Locale = _PropertyGet("Locale") + +End Property ' ScriptForge.SF_L10N.Locale + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AddText(Optional ByVal Context As Variant _ + , Optional ByVal MsgId As Variant _ + , Optional ByVal Comment As Variant _ + , Optional ByVal MsgStr As Variant _ + ) As Boolean +''' Add a new entry in the list of localizable text strings +''' Args: +''' Context: when not empty, the key to retrieve the translated string via GetText. Default = "" +''' MsgId: the untranslated string, i.e. the text appearing in the program code. Must not be empty +''' The key to retrieve the translated string via GetText when Context is empty +''' May contain placeholders (%1 ... %9) for dynamic arguments to be inserted in the text at run-time +''' If the string spans multiple lines, insert escape sequences (\n) where relevant +''' Comment: the so-called "extracted-comments" intended to inform/help translators +''' If the string spans multiple lines, insert escape sequences (\n) where relevant +''' MsgStr: (internal use only) the translated string +''' If the string spans multiple lines, insert escape sequences (\n) where relevant +''' Returns: +''' True if successful +''' Exceptions: +''' DUPLICATEKEYERROR: such a key exists already +''' Examples: +''' myPO.AddText(, "This is a text to be included in a POT file") + +Dim bAdd As Boolean ' Output buffer +Dim sKey As String ' The key part of the new entry in the dictionary +Dim vItem As POEntry ' The item part of the new entry in the dictionary +Const cstPipe = "|" ' Pipe forbidden in MsgId's +Const cstThisSub = "L10N.AddText" +Const cstSubArgs = "[Context=""""], MsgId, [Comment=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bAdd = False + +Check: + If IsMissing(Context) Or IsMissing(Context) Then Context = "" + If IsMissing(Comment) Or IsMissing(Comment) Then Comment = "" + If IsMissing(MsgStr) Or IsMissing(MsgStr) Then MsgStr = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Context, "Context", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(MsgId, "MsgId", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Comment, "Comment", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(MsgStr, "MsgStr", V_STRING) Then GoTo Finally + End If + If Len(MsgId) = 0 Then GoTo Finally + +Try: + If Len(Context) > 0 Then sKey = Context Else sKey = MsgId + If _Dictionary.Exists(sKey) Then GoTo CatchDuplicate + + With vItem + .Comment = Comment + If InStr(MsgId, "%") > 0 Then .Flag = "kde-format" Else .Flag = "" + .Context = Replace(Context, cstPipe, " ") + .MsgId = Replace(MsgId, cstPipe, " ") + .MsgStr = MsgStr + End With + _Dictionary.Add(sKey, vItem) + bAdd = True + +Finally: + AddText = bAdd + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDuplicate: + SF_Exception.RaiseFatal(DUPLICATEKEYERROR, Iif(Len(Context) > 0, "Context", "MsgId"), sKey) + GoTo Finally +End Function ' ScriptForge.SF_L10N.AddText + +REM ----------------------------------------------------------------------------- +Public Function AddTextsFromDialog(Optional ByRef Dialog As Variant) As Boolean +''' Add all fixed text strings of a dialog to the list of localizable text strings +''' Added texts are: +''' - the title of the dialog +''' - the caption associated with next control types: Button, CheckBox, FixedLine, FixedText, GroupBox and RadioButton +''' - the content of list- and comboboxes +''' - the tip- or helptext displayed when the mouse is hovering the control +''' The current method has method SFDialogs.SF_Dialog.GetTextsFromL10N as counterpart +''' The targeted dialog must not be open when the current method is run +''' Args: +''' Dialog: a SFDialogs.Dialog service instance +''' Returns: +''' True when successful +''' Examples: +''' Dim myDialog As Object +''' Set myDialog = CreateScriptService("SFDialogs.Dialog", "GlobalScope", "XrayTool", "DlgXray") +''' myPO.AddTextsFromDialog(myDialog) + +Dim bAdd As Boolean ' Return value +Dim vControls As Variant ' Array of control names +Dim sControl As String ' A single control name +Dim oControl As Object ' SFDialogs.DialogControl +Dim sText As String ' The text to insert in the dictionary +Dim sDialogComment As String ' The prefix in the comment to insert in the dictionary for the dialog +Dim sControlComment As String ' The prefix in the comment to insert in the dictionary for a control +Dim vSource As Variant ' RowSource property of dialog control as an array +Dim i As Long + +Const cstThisSub = "L10N.AddTextsFromDialog" +Const cstSubArgs = "Dialog" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bAdd = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Dialog, "Dialog", V_OBJECT, , , "DIALOG") Then GoTo Finally + End If + +Try: + With Dialog + ' Store the title of the dialog + sDialogComment = "Dialog => " & ._Container & " : " & ._Library & " : " & ._Name & " : " + stext = .Caption + If Len(sText) > 0 Then + If Not _ReplaceText("", sText, sDialogComment & "Caption") Then GoTo Catch + End If + ' Scan all controls + vControls = .Controls() + For Each sControl In vControls + Set oControl = .Controls(sControl) + sControlComment = sDialogComment & sControl & "." + With oControl + ' Extract fixed texts + sText = .Caption + If Len(sText) > 0 Then + If Not _ReplaceText("", sText, sControlComment & "Caption") Then GoTo Catch + End If + vSource = .RowSource ' List and comboboxes only + If IsArray(vSource) Then + For i = 0 To UBound(vSource) + If Len(vSource(i)) > 0 Then + If Not _ReplaceText("", vSource(i), sControlComment & "RowSource[" & i & "]") Then GoTo Catch + End If + Next i + End If + sText = .TipText + If Len(sText) > 0 Then + If Not _ReplaceText("", sText, sControlComment & "TipText") Then GoTo Catch + End If + End With + Next sControl + End With + + bAdd = True + +Finally: + AddTextsFromDialog = bAdd + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N.AddTextsFromDialog + +REM ----------------------------------------------------------------------------- +Public Function ExportToPOTFile(Optional ByVal FileName As Variant _ + , Optional ByVal Header As Variant _ + , Optional ByVal Encoding As Variant _ + ) As Boolean +''' Export a set of untranslated strings as a POT file +''' The set of strings has been built either by a succession of AddText() methods +''' or by a successful invocation of the L10N service with the FolderName argument +''' The generated file should pass successfully the "msgfmt --check 'the pofile'" GNU command +''' Args: +''' FileName: the complete file name to export to. If it exists, is overwritten without warning +''' Header: Comments that will appear on top of the generated file. Do not include any leading "#" +''' If the string spans multiple lines, insert escape sequences (\n) where relevant +''' A standard header will be added anyway +''' Encoding: The character set that should be used +''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Note that LibreOffice probably does not implement all existing sets +''' Default = UTF-8 +''' Returns: +''' True if successful +''' Examples: +''' myPO.ExportToPOTFile("myFile.pot", Header := "Top comment\nSecond line of top comment") + +Dim bExport As Boolean ' Return value +Dim oFile As Object ' Generated file handler +Dim vLines As Variant ' Wrapped lines +Dim sLine As String ' A single line +Dim vItems As Variant ' Array of dictionary items +Dim vItem As Variant ' POEntry type +Const cstSharp = "# ", cstSharpDot = "#. ", cstFlag = "#, kde-format" +Const cstTabSize = 4 +Const cstWrap = 70 +Const cstThisSub = "L10N.ExportToPOTFile" +Const cstSubArgs = "FileName, [Header=""""], [Encoding=""UTF-8""" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bExport = False + +Check: + If IsMissing(Header) Or IsEmpty(Header) Then Header = "" + If IsMissing(Encoding) Or IsEmpty(Encoding) Then Encoding = "UTF-8" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Header, "Header", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Encoding, "Encoding", V_STRING) Then GoTo Finally + End If + +Try: + Set oFile = SF_FileSystem.CreateTextFile(FileName, Overwrite := True, Encoding := Encoding) + If Not IsNull(oFile) Then + With oFile + ' Standard header + .WriteLine(cstSharp) + .WriteLine(cstSharp & "This pristine POT file has been generated by LibreOffice/ScriptForge") + .WriteLine(cstSharp & "Full documentation is available on https://help.libreoffice.org/") + ' User header + If Len(Header) > 0 Then + .WriteLine(cstSharp) + vLines = SF_String.Wrap(Header, cstWrap, cstTabSize) + For Each sLine In vLines + .WriteLine(cstSharp & Replace(sLine, SF_String.sfLF, "")) + Next sLine + End If + ' Standard header + .WriteLine(cstSharp) + .WriteLine("msgid """"") + .WriteLine("msgstr """"") + .WriteLine(SF_String.Quote("Project-Id-Version: PACKAGE VERSION\n")) + .WriteLine(SF_String.Quote("Report-Msgid-Bugs-To: " _ + & "https://bugs.libreoffice.org/enter_bug.cgi?product=LibreOffice&bug_status=UNCONFIRMED&component=UI\n")) + .WriteLine(SF_String.Quote("POT-Creation-Date: " & SF_STring.Represent(Now()) & "\n")) + .WriteLine(SF_String.Quote("PO-Revision-Date: YYYY-MM-DD HH:MM:SS\n")) + .WriteLine(SF_String.Quote("Last-Translator: FULL NAME <EMAIL@ADDRESS>\n")) + .WriteLine(SF_String.Quote("Language-Team: LANGUAGE <EMAIL@ADDRESS>\n")) + .WriteLine(SF_String.Quote("Language: en_US\n")) + .WriteLine(SF_String.Quote("MIME-Version: 1.0\n")) + .WriteLine(SF_String.Quote("Content-Type: text/plain; charset=" & Encoding & "\n")) + .WriteLine(SF_String.Quote("Content-Transfer-Encoding: 8bit\n")) + .WriteLine(SF_String.Quote("Plural-Forms: nplurals=2; plural=n > 1;\n")) + .WriteLine(SF_String.Quote("X-Generator: LibreOffice - ScriptForge\n")) + .WriteLine(SF_String.Quote("X-Accelerator-Marker: ~\n")) + ' Individual translatable strings + vItems = _Dictionary.Items() + For Each vItem in vItems + .WriteBlankLines(1) + ' Comments + vLines = Split(vItem.Comment, "\n") + For Each sLine In vLines + .WriteLine(cstSharpDot & SF_String.ExpandTabs(SF_String.Unescape(sLine), cstTabSize)) + Next sLine + ' Flag + If InStr(vItem.MsgId, "%") > 0 Then .WriteLine(cstFlag) + ' Context + If Len(vItem.Context) > 0 Then + .WriteLine("msgctxt " & SF_String.Quote(vItem.Context)) + End If + ' MsgId + vLines = SF_String.Wrap(vItem.MsgId, cstWrap, cstTabSize) + If UBound(vLines) = 0 Then + .WriteLine("msgid " & SF_String.Quote(SF_String.Escape(vLines(0)))) + Else + .WriteLine("msgid """"") + For Each sLine in vLines + .WriteLine(SF_String.Quote(SF_String.Escape(sLine))) + Next sLine + End If + ' MsgStr + .WriteLine("msgstr """"") + Next vItem + .CloseFile() + End With + End If + bExport = True + +Finally: + If Not IsNull(oFile) Then Set oFile = oFile.Dispose() + ExportToPOTFile = bExport + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N.ExportToPOTFile + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myL10N.GetProperty("MyProperty") + +Const cstThisSub = "L10N.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetText(Optional ByVal MsgId As Variant _ + , ParamArray pvArgs As Variant _ + ) As String +''' Get the translated string corresponding with the given argument +''' Args: +''' MsgId: the identifier of the string or the untranslated string +''' Either - the untranslated text (MsgId) +''' - the reference to the untranslated text (Context) +''' - both (Context|MsgId) : the pipe character is essential +''' pvArgs(): a list of arguments present as %1, %2, ... in the (un)translated string) +''' to be substituted in the returned string +''' Any type is admitted but only strings, numbers or dates are relevant +''' Returns: +''' The translated string +''' If not found the MsgId string or the Context string +''' Anyway the substitution is done +''' Examples: +''' myPO.GetText("This is a text to be included in a POT file") +''' ' Ceci est un text à inclure dans un fichier POT + +Dim sText As String ' Output buffer +Dim sContext As String ' Context part of argument +Dim sMsgId As String ' MsgId part of argument +Dim vItem As POEntry ' Entry in the dictionary +Dim vMsgId As Variant ' MsgId split on pipe +Dim sKey As String ' Key of dictionary +Dim sPercent As String ' %1, %2, ... placeholders +Dim i As Long +Const cstPipe = "|" +Const cstThisSub = "L10N.GetText" +Const cstSubArgs = "MsgId, [Arg0, Arg1, ...]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sText = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(MsgId, "MsgId", V_STRING) Then GoTo Finally + End If + If Len(Trim(MsgId)) = 0 Then GoTo Finally + sText = MsgId + +Try: + ' Find and load entry from dictionary + If Left(MsgId, 1) = cstPipe then MsgId = Mid(MsgId, 2) + vMsgId = Split(MsgId, cstPipe) + sKey = vMsgId(0) + If Not _Dictionary.Exists(sKey) Then ' Not found + If UBound(vMsgId) = 0 Then sText = vMsgId(0) Else sText = Mid(MsgId, InStr(MsgId, cstPipe) + 1) + Else + vItem = _Dictionary.Item(sKey) + If Len(vItem.MsgStr) > 0 Then sText = vItem.MsgStr Else sText = vItem.MsgId + End If + + ' Substitute %i placeholders + For i = UBound(pvArgs) To 0 Step -1 ' Go downwards to not have a limit in number of args + sPercent = "%" & (i + 1) + sText = Replace(sText, sPercent, SF_String.Represent(pvArgs(i))) + Next i + +Finally: + GetText = sText + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N.GetText + +REM - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +Public Function _(Optional ByVal MsgId As Variant _ + , ParamArray pvArgs As Variant _ + ) As String +''' Get the translated string corresponding with the given argument +''' Alias of GetText() - See above +''' Examples: +''' myPO._("This is a text to be included in a POT file") +''' ' Ceci est un text à inclure dans un fichier POT + +Dim sText As String ' Output buffer +Dim sPercent As String ' %1, %2, ... placeholders +Dim i As Long +Const cstPipe = "|" +Const cstThisSub = "L10N._" +Const cstSubArgs = "MsgId, [Arg0, Arg1, ...]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sText = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(MsgId, "MsgId", V_STRING) Then GoTo Finally + End If + If Len(Trim(MsgId)) = 0 Then GoTo Finally + +Try: + ' Find and load entry from dictionary + sText = GetText(MsgId) + + ' Substitute %i placeholders - done here, not in GetText(), because # of arguments is undefined + For i = 0 To UBound(pvArgs) + sPercent = "%" & (i + 1) + sText = Replace(sText, sPercent, SF_String.Represent(pvArgs(i))) + Next i + +Finally: + _ = sText + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N._ + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the L10N service as an array + + Methods = Array( _ + "AddText" _ + , "ExportToPOTFile" _ + , "GetText" _ + , "AddTextsFromDialog" _ + , "_" _ + ) + +End Function ' ScriptForge.SF_L10N.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "Folder" _ + , "Languages" _ + , "Locale" _ + ) + +End Function ' ScriptForge.SF_L10N.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "L10N.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize(ByVal psPOFile As String _ + , ByVal Encoding As String _ + ) +''' Completes initialization of the current instance requested from CreateScriptService() +''' Load the POFile in the dictionary, otherwise leave the dictionary empty +''' Args: +''' psPOFile: the file to load the translated strings from +''' Encoding: The character set that should be used. Default = UTF-8 + +Dim oFile As Object ' PO file handler +Dim sContext As String ' Collected context string +Dim sMsgId As String ' Collected untranslated string +Dim sComment As String ' Collected comment string +Dim sMsgStr As String ' Collected translated string +Dim sLine As String ' Last line read +Dim iContinue As Integer ' 0 = None, 1 = MsgId, 2 = MsgStr +Const cstMsgId = 1, cstMsgStr = 2 + +Try: + ' Initialize dictionary anyway + Set _Dictionary = SF_Services.CreateScriptService("Dictionary") + Set _Dictionary.[_Parent] = [Me] + + ' Load PO file + If Len(psPOFile) > 0 Then + With SF_FileSystem + _POFolder = ._ConvertToUrl(.GetParentFolderName(psPOFile)) + _Locale = .GetBaseName(psPOFile) + _POFile = ._ConvertToUrl(psPOFile) + End With + ' Load PO file + Set oFile = SF_FileSystem.OpenTextFile(psPOFile, IOMode := SF_FileSystem.ForReading, Encoding := Encoding) + If Not IsNull(oFile) Then + With oFile + ' The PO file is presumed valid => syntax check is not very strict + sContext = "" : sMsgId = "" : sComment = "" : sMsgStr = "" + Do While Not .AtEndOfStream + sLine = Trim(.ReadLine()) + ' Trivial examination of line header + Select Case True + Case sLine = "" + If Len(sMsgId) > 0 Then AddText(sContext, sMsgId, sComment, sMsgStr) + sContext = "" : sMsgId = "" : sComment = "" : sMsgStr = "" + iContinue = 0 + Case Left(sLine, 3) = "#. " + sComment = sComment & Iif(Len(sComment) > 0, "\n", "") & Trim(Mid(sLine, 4)) + iContinue = 0 + Case Left(sLine, 8) = "msgctxt " + sContext = SF_String.Unquote(Trim(Mid(sLine, 9))) + iContinue = 0 + Case Left(sLine, 6) = "msgid " + sMsgId = SF_String.Unquote(Trim(Mid(sLine, 7))) + iContinue = cstMsgId + Case Left(sLine, 7) = "msgstr " + sMsgStr = sMsgStr & SF_String.Unquote(Trim(Mid(sLine, 8))) + iContinue = cstMsgStr + Case Left(sLine, 1) = """" + If iContinue = cstMsgId Then + sMsgId = sMsgId & SF_String.Unquote(sLine) + ElseIf iContinue = cstMsgStr Then + sMsgStr = sMsgStr & SF_String.Unquote(sLine) + Else + iContinue = 0 + End If + Case Else ' Skip line + iContinue = 0 + End Select + Loop + ' Be sure to store the last entry + If Len(sMsgId) > 0 Then AddText(sContext, sMsgId, sComment, sMsgStr) + .CloseFile() + Set oFile = .Dispose() + End With + End If + Else + _POFolder = "" + _Locale = "" + _POFile = "" + End If + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_L10N._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim vFiles As Variant ' Array of PO-files +Dim i As Long +Dim cstThisSub As String +Dim cstSubArgs As String + + cstThisSub = "SF_L10N.get" & psProperty + cstSubArgs = "" + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + With SF_FileSystem + Select Case psProperty + Case "Folder" + If Len(_POFolder) > 0 Then _PropertyGet = ._ConvertFromUrl(_POFolder) Else _PropertyGet = "" + Case "Languages" + If Len(_POFolder) > 0 Then + vFiles = .Files(._ConvertFromUrl(_POFolder), "*.po") + For i = 0 To UBound(vFiles) + vFiles(i) = SF_FileSystem.GetBaseName(vFiles(i)) + Next i + Else + vFiles = Array() + End If + _PropertyGet = vFiles + Case "Locale" + _PropertyGet = _Locale + Case Else + _PropertyGet = Null + End Select + End With + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_L10N._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _ReplaceText(ByVal psContext As String _ + , ByVal psMsgId As String _ + , ByVal psComment As String _ + ) As Boolean +''' When the entry in the dictionary does not yet exist, equivalent to AddText +''' When it exists already, extend the existing comment with the psComment argument +''' Used from AddTextsFromDialog to manage identical strings without raising errors, +''' e.g. when multiple dialogs have the same "Close" button + +Dim bAdd As Boolean ' Return value +Dim sKey As String ' The key part of an entry in the dictionary +Dim vItem As POEntry ' The item part of the new entry in the dictionary + +Try: + bAdd = False + If Len(psContext) > 0 Then sKey = psContext Else sKey = psMsgId + If _Dictionary.Exists(sKey) Then + ' Load the entry, adapt comment and rewrite + vItem = _Dictionary.Item(sKey) + If Len(vItem.Comment) = 0 Then vItem.Comment = psComment Else vItem.Comment = vItem.Comment & "\n" & psComment + bAdd = _Dictionary.ReplaceItem(sKey, vItem) + Else + ' Add a new entry as usual + bAdd = AddText(psContext, psMsgId, psComment) + End If + +Finally: + _ReplaceText = bAdd + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_L10N._ReplaceText + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the L10N instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[L10N]: PO file" + + _Repr = "[L10N]: " & _POFile + +End Function ' ScriptForge.SF_L10N._Repr + +REM ============================================ END OF SCRIPTFORGE.SF_L10N + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Platform.xba b/wizards/source/scriptforge/SF_Platform.xba new file mode 100644 index 000000000..8403866ff --- /dev/null +++ b/wizards/source/scriptforge/SF_Platform.xba @@ -0,0 +1,451 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Platform +''' =========== +''' Singleton class implementing the "ScriptForge.Platform" service +''' Implemented as a usual Basic module +''' +''' A collection of properties about the execution environment: +''' - HW platform +''' - Operating System +''' - current user +''' - LibreOffice version +''' +''' Service invocation example: +''' Dim platform As Variant +''' platform = CreateScriptService("Platform") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_platform.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ============================================================ MODULE CONSTANTS + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_Array Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Architecture() As String +''' Returns the actual bit architecture +''' Example: +''' MsgBox platform.Architecture ' 64bit + Architecture = _PropertyGet("Architecture") +End Property ' ScriptForge.SF_Platform.Architecture (get) + +REM ----------------------------------------------------------------------------- +Property Get ComputerName() As String +''' Returns the computer's network name +''' Example: +''' MsgBox platform.ComputerName + ComputerName = _PropertyGet("ComputerName") +End Property ' ScriptForge.SF_Platform.ComputerName (get) + +REM ----------------------------------------------------------------------------- +Property Get CPUCount() As Integer +''' Returns the number of Central Processor Units +''' Example: +''' MsgBox platform.CPUCount ' 4 + CPUCount = _PropertyGet("CPUCount") +End Property ' ScriptForge.SF_Platform.CPUCount (get) + +REM ----------------------------------------------------------------------------- +Property Get CurrentUser() As String +''' Returns the name of logged in user +''' Example: +''' MsgBox platform.CurrentUser + CurrentUser = _PropertyGet("CurrentUser") +End Property ' ScriptForge.SF_Platform.CurrentUser (get) + +REM ----------------------------------------------------------------------------- +Property Get Extensions() As Variant +''' Returns the list of availableeExtensions as an unsorted array of unique strings +''' To get the list sorted, use SF_Array.Sort() +''' Example: +''' myExtensionsList = platform.Extensions + Extensions = _PropertyGet("Extensions") +End Property ' ScriptForge.SF_Platform.Extensions (get) + +REM ----------------------------------------------------------------------------- +Property Get FilterNames() As Variant +''' Returns the list of available document import and export filter names as an unsorted array of unique strings +''' To get the list sorted, use SF_Array.Sort() +''' Example: +''' myFilterNamesList = platform.FilterNames + FilterNames = _PropertyGet("FilterNames") +End Property ' ScriptForge.SF_Platform.FilterNames (get) + +REM ----------------------------------------------------------------------------- +Property Get Fonts() As Variant +''' Returns the list of available fonts as an unsorted array of unique strings +''' To get the list sorted, use SF_Array.Sort() +''' Example: +''' myFontsList = platform.Fonts + Fonts = _PropertyGet("Fonts") +End Property ' ScriptForge.SF_Platform.Fonts (get) + +REM ----------------------------------------------------------------------------- +Property Get FormatLocale() As String +''' Returns the locale used for number and date formats, combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox platform.FormatLocale + FormatLocale = _PropertyGet("FormatLocale") +End Property ' ScriptForge.SF_Platform.FormatLocale (get) + +REM ----------------------------------------------------------------------------- +Property Get Locale() As String +''' Returns the locale of the operating system, combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox platform.Locale + Locale = _PropertyGet("Locale") +End Property ' ScriptForge.SF_Platform.Locale (get) + +REM ----------------------------------------------------------------------------- +Property Get Machine() As String +''' Returns the machine type like 'i386' or 'x86_64' +''' Example: +''' MsgBox platform.Machine + Machine = _PropertyGet("Machine") +End Property ' ScriptForge.SF_Platform.Machine (get) + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_Platform" +End Property ' ScriptForge.SF_Platform.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get OfficeLocale() As String +''' Returns the locale of the user interface, combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox platform.OfficeLocale + OfficeLocale = _PropertyGet("OfficeLocale") +End Property ' ScriptForge.SF_Platform.OfficeLocale (get) + +REM ----------------------------------------------------------------------------- +Property Get OfficeVersion() As String +''' Returns the office software version in the form 'LibreOffice w.x.y.z (The Document Foundation)' +''' Example: +''' MsgBox platform.OfficeVersion + OfficeVersion = _PropertyGet("OfficeVersion") +End Property ' ScriptForge.SF_Platform.OfficeVersion (get) + +REM ----------------------------------------------------------------------------- +Property Get OSName() As String +''' Returns the name of the operating system like 'Linux' or 'Windows' +''' Example: +''' MsgBox platform.OSName + OSName = _PropertyGet("OSName") +End Property ' ScriptForge.SF_Platform.OSName (get) + +REM ----------------------------------------------------------------------------- +Property Get OSPlatform() As String +''' Returns a single string identifying the underlying platform with as much useful and human-readable information as possible +''' Example: +''' MsgBox platform.OSPlatform ' Linux-4.15.0-117-generic-x86_64-with-Ubuntu-18.04-bionic + OSPlatform = _PropertyGet("OSPlatform") +End Property ' ScriptForge.SF_Platform.OSPlatform (get) + +REM ----------------------------------------------------------------------------- +Property Get OSRelease() As String +''' Returns the operating system's release +''' Example: +''' MsgBox platform.OSRelease ' 4.15.0-117-generic + OSRelease = _PropertyGet("OSRelease") +End Property ' ScriptForge.SF_Platform.OSRelease (get) + +REM ----------------------------------------------------------------------------- +Property Get OSVersion() As String +''' Returns the name of the operating system build or version +''' Example: +''' MsgBox platform.OSVersion ' #118-Ubuntu SMP Fri Sep 4 20:02:41 UTC 2020 + OSVersion = _PropertyGet("OSVersion") +End Property ' ScriptForge.SF_Platform.OSVersion (get) + +REM ----------------------------------------------------------------------------- +Property Get Printers() As Variant +''' Returns the list of available printers type as a zero-based array +''' The default printer is put in the 1st position in the list (index = 0) +''' Example: +''' MsgBox join(platform.Printers, ",") + Printers = _PropertyGet("Printers") +End Property ' ScriptForge.SF_Platform.Printers (get) + +REM ----------------------------------------------------------------------------- +Property Get Processor() As String +''' Returns the (real) processor name, e.g. 'amdk6'. Might return the same value as Machine +''' Example: +''' MsgBox platform.Processor + Processor = _PropertyGet("Processor") +End Property ' ScriptForge.SF_Platform.Processor (get) + +REM ----------------------------------------------------------------------------- +Property Get PythonVersion() As String +''' Returns the Python version as string 'Python major.minor.patchlevel' +''' Example: +''' MsgBox platform.PythonVersion ' Python 3.7.7 + PythonVersion = _PropertyGet("PythonVersion") +End Property ' ScriptForge.SF_Platform.PythonVersion (get) + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.Platform" +End Property ' ScriptForge.SF_Platform.ServiceName + +REM ----------------------------------------------------------------------------- +Property Get SystemLocale() As String +''' Returns the locale of the operating system, combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox platform.SystemLocale + SystemLocale = _PropertyGet("SystemLocale") +End Property ' ScriptForge.SF_Platform.SystemLocale (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Platform.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Platform.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + ) + +End Function ' ScriptForge.SF_Platform.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Platform class as an array + + Properties = Array( _ + "Architecture" _ + , "ComputerName" _ + , "CPUCount" _ + , "CurrentUser" _ + , "Extensions" _ + , "FilterNames" _ + , "Fonts" _ + , "FormatLocale" _ + , "Locale" _ + , "Machine" _ + , "OfficeLocale" _ + , "OfficeVersion" _ + , "OSName" _ + , "OSPlatform" _ + , "OSRelease" _ + , "OSVersion" _ + , "Printers" _ + , "Processor" _ + , "PythonVersion" _ + , "SystemLocale" _ + ) + +End Function ' ScriptForge.SF_Platform.Properties + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _GetPrinters() as Variant +''' Returns the list of available printers. +''' The default printer is put in the 1st position (index = 0) + +Dim oPrinterServer As Object ' com.sun.star.awt.PrinterServer +Dim vPrinters As Variant ' Array of printer names +Dim sDefaultPrinter As String ' The default printer +Dim lDefault As Long ' Initial position of the default printer in the list + + On Local Error GoTo Catch ' Prevent any error + vPrinters = Array() + +Try: + ' Find printers + Set oPrinterServer = SF_Utils._GetUNOService("PrinterServer") + With oPrinterServer + vPrinters = .getPrinterNames() + sDefaultPrinter = .getDefaultPrinterName() + End With + + ' Put the default printer on top of the list + If Len(sDefaultPrinter) > 0 Then + lDefault = SF_Array.IndexOf(vPrinters, sDefaultPrinter, CaseSensitive := True) + If lDefault > 0 Then ' Invert 2 printers + vPrinters(lDefault) = vPrinters(0) + vPrinters(0) = sDefaultPrinter + End If + End If + +Finally: + _GetPrinters() = vPrinters() + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Platform._GetPrinters + +REM ----------------------------------------------------------------------------- +Public Function _GetProductName() as String +''' Returns Office product and version numbers found in configuration registry +''' Derived from the Tools library + +Dim oProdNameAccess as Object ' configmgr.RootAccess +Dim sProdName as String +Dim sVersion as String +Dim sVendor As String + + On Local Error GoTo Catch ' Prevent any error + _GetProductName = "" + +Try: + Set oProdNameAccess = SF_Utils._GetRegistryKeyContent("org.openoffice.Setup/Product") + + sProdName = oProdNameAccess.ooName + sVersion = oProdNameAccess.ooSetupVersionAboutBox + sVendor = oProdNameAccess.ooVendor + + _GetProductName = sProdName & " " & sVersion & " (" & sVendor & ")" + +Finally: + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Platform._GetProductName + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim sOSName As String ' Operating system +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oPrinterServer As Object ' com.sun.star.awt.PrinterServer +Dim oToolkit As Object ' com.sun.star.awt.Toolkit +Dim oDevice As Object ' com.sun.star.awt.XDevice +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim oFontDescriptors As Variant ' Array of com.sun.star.awt.FontDescriptor +Dim sFonts As String ' Comma-separated list of fonts +Dim sFont As String ' A single font name +Dim vExtensionsList As Variant ' Array of extension descriptors +Dim sExtensions As String ' Comma separated list of extensions +Dim sExtension As String ' A single extension name +Dim i As Long + +Const cstPyHelper = "$" & "_SF_Platform" +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "Platform.get" & psProperty + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case psProperty + Case "Architecture", "ComputerName", "CPUCount", "CurrentUser", "Machine" _ + , "OSPlatform", "OSRelease", "OSVersion", "Processor", "PythonVersion" + With ScriptForge.SF_Session + _PropertyGet = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, psProperty) + End With + Case "Extensions" + Set vExtensionsList = SF_Utils._GetUnoService("PackageInformationProvider").ExtensionList + sExtensions = "" + For i = 0 To UBound(vExtensionsList) + sExtensions = sExtensions & "," & vExtensionsList(i)(0) + Next i + If Len(sExtensions) > 0 Then _PropertyGet = Split(Mid(sExtensions, 2), ",") Else _PropertyGet = Array() + Case "FilterNames" + Set oFilterFactory = SF_Utils._GetUNOService("FilterFactory") + _PropertyGet = oFilterFactory.getElementNames() + Case "Fonts" + Set oToolkit = SF_Utils._GetUnoService("Toolkit") + Set oDevice = oToolkit.createScreenCompatibleDevice(0, 0) + oFontDescriptors = oDevice.FontDescriptors() + sFonts = "," + ' Select only not yet registered fonts + For i = 0 To UBound(oFontDescriptors) + sFont = oFontDescriptors(i).Name + If InStr(1, sFonts, "," & sFont & ",", 0) = 0 Then sFonts = sFonts & sFont & "," ' Case-sensitive comparison + Next i + ' Remove leading and trailing commas + If Len(sFonts) > 1 Then _PropertyGet = Split(Mid(sFonts, 2, Len(sFonts) - 2), ",") Else _PropertyGet = Array() + Case "FormatLocale" + Set oLocale = SF_Utils._GetUNOService("FormatLocale") + _PropertyGet = oLocale.Language & "-" & oLocale.Country + Case "OfficeLocale" + Set oLocale = SF_Utils._GetUNOService("OfficeLocale") + _PropertyGet = oLocale.Language & "-" & oLocale.Country + Case "OfficeVersion" + _PropertyGet = _GetProductName() + Case "OSName" + ' Calc INFO function preferred to Python script to avoid ScriptForge initialization risks when Python is not installed + sOSName = _SF_.OSName + If sOSName = "" Then + sOSName = SF_Session.ExecuteCalcFunction("INFO", "system") + Select Case sOSName + Case "WNT" : sOSName = "Windows" + Case "MACOSX" : sOSName = "macOS" + Case "LINUX" : sOSName = "Linux" + Case "SOLARIS" : sOSName = "Solaris" + Case Else : sOSName = SF_String.Capitalize(sOSName) + End Select + EndIf + _PropertyGet = sOSName + Case "Printers" + _PropertyGet = _GetPrinters() + Case "SystemLocale", "Locale" + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + _PropertyGet = oLocale.Language & "-" & oLocale.Country + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Platform._PropertyGet + +REM ============================================ END OF SCRIPTFORGE.SF_PLATFORM + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_PythonHelper.xba b/wizards/source/scriptforge/SF_PythonHelper.xba new file mode 100644 index 000000000..99d9f86c6 --- /dev/null +++ b/wizards/source/scriptforge/SF_PythonHelper.xba @@ -0,0 +1,967 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_PythonHelper (aka Basic) +''' =============== +''' Singleton class implementing the "ScriptForge.Basic" service +''' Implemented as a usual Basic module +''' +''' The "Basic" service must be called ONLY from a PYTHON script +''' Service invocations: Next Python code lines are equivalent: +''' bas = CreateScriptService('ScriptForge.Basic') +''' bas = CreateScriptService('Basic') +''' +''' This service proposes a collection of methods to be executed in a Python context +''' to simulate the exact behaviour of the identical Basic builtin method. +''' Typical example: +''' bas.MsgBox('This has to be displayed in a message box') +''' +''' The service includes also an agnostic "Python Dispatcher" function. +''' It dispatches Python script requests to execute Basic services to the +''' appropriate properties and methods via dynamic call techniques +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ============================================================ MODULE CONSTANTS + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_PythonHelper Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_PythonHelper" +End Property ' ScriptForge.SF_PythonHelper.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.Basic" +End Property ' ScriptForge.SF_PythonHelper.ServiceName + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function PyCDate(ByVal DateArg As Variant) As Variant +''' Convenient function to replicate CDate() in Python scripts +''' Args: +''' DateArg: a date as a string or as a double +''' Returns: +''' The converted date as a UNO DateTime structure +''' If the input argument could not be recognized as a date, return the argument unchanged +''' Example: (Python code) +''' a = bas.CDate('2021-02-18') + +Dim vDate As Variant ' Return value +Const cstThisSub = "Basic.CDate" +Const cstSubArgs = "datearg" + + On Local Error GoTo Catch + vDate = Null + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + vDate = CDate(DateArg) + +Finally: + If VarType(vDate) = V_DATE Then PyCDate = CDateToUnoDateTime(vDate) Else PyCDate = DateArg + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + On Local Error GoTo 0 + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyCDate + +REM ----------------------------------------------------------------------------- +Public Function PyConvertFromUrl(ByVal FileName As Variant) As String +''' Convenient function to replicate ConvertFromUrl() in Python scripts +''' Args: +''' FileName: a string representing a file in URL format +''' Returns: +''' The same file name in native operating system notation +''' Example: (Python code) +''' a = bas.ConvertFromUrl('file:////boot.sys') + +Dim sFileName As String ' Return value +Const cstThisSub = "Basic.ConvertFromUrl" +Const cstSubArgs = "filename" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFileName = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + sFileName = ConvertFromUrl(FileName) + +Finally: + PyConvertFromUrl = sFileName + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyConvertFromUrl + +REM ----------------------------------------------------------------------------- +Public Function PyConvertToUrl(ByVal FileName As Variant) As String +''' Convenient function to replicate ConvertToUrl() in Python scripts +''' Args: +''' FileName: a string representing a file in native operating system notation +''' Returns: +''' The same file name in URL format +''' Example: (Python code) +''' a = bas.ConvertToUrl('C:\boot.sys') + +Dim sFileName As String ' Return value +Const cstThisSub = "Basic.ConvertToUrl" +Const cstSubArgs = "filename" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFileName = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + sFileName = ConvertToUrl(FileName) + +Finally: + PyConvertToUrl = sFileName + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyConvertToUrl + +REM ----------------------------------------------------------------------------- +Public Function PyCreateUnoService(ByVal UnoService As Variant) As Variant +''' Convenient function to replicate CreateUnoService() in Python scripts +''' Args: +''' UnoService: a string representing the service to create +''' Returns: +''' A UNO object +''' Example: (Python code) +''' a = bas.CreateUnoService('com.sun.star.i18n.CharacterClassification') + +Dim vUno As Variant ' Return value +Const cstThisSub = "Basic.CreateUnoService" +Const cstSubArgs = "unoservice" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set vUno = Nothing + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + Set vUno = CreateUnoService(UnoService) + +Finally: + Set PyCreateUnoService = vUno + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyCreateUnoService + +REM ----------------------------------------------------------------------------- +Public Function PyDateAdd(ByVal Add As Variant _ + , ByVal Count As Variant _ + , ByVal DateArg As Variant _ + ) As Variant +''' Convenient function to replicate DateAdd() in Python scripts +''' Args: +''' Add: The unit to add +''' Count: how many times to add (might be negative) +''' DateArg: a date as a com.sun.star.util.DateTime UNO structure +''' Returns: +''' The new date as a string in iso format +''' Example: (Python code) +''' a = bas.DateAdd('d', 1, bas.Now()) ' Tomorrow + +Dim vNewDate As Variant ' Return value +Dim vDate As Date ' Alias of DateArg +Const cstThisSub = "Basic.DateAdd" +Const cstSubArgs = "add, count, datearg" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vNewDate = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If VarType(DateArg) = V_OBJECT Then + vDate = CDateFromUnoDateTime(DateArg) + Else + vDate = SF_Utils._CStrToDate(DateArg) + End If + vNewDate = DateAdd(Add, Count, vDate) + +Finally: + If VarType(vNewDate) = V_DATE Then PyDateAdd = CDateToUnoDateTime(vNewDate) Else PyDateAdd = vNewDate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyDateAdd + +REM ----------------------------------------------------------------------------- +Public Function PyDateDiff(ByVal Add As Variant _ + , ByVal Date1 As Variant _ + , ByVal Date2 As Variant _ + , ByVal WeekStart As Variant _ + , ByVal YearStart As Variant _ + ) As Long +''' Convenient function to replicate DateDiff() in Python scripts +''' Args: +''' Add: The unit of the date interval +''' Date1, Date2: the two dates to be compared +''' WeekStart: the starting day of a week +''' YearStart: the starting week of a year +''' Returns: +''' The number of intervals expressed in Adds +''' Example: (Python code) +''' a = bas.DateDiff('d', bas.DateAdd('d', 1, bas.Now()), bas.Now()) ' -1 day + +Dim lDiff As Long ' Return value +Dim vDate1 As Date ' Alias of Date1 +Dim vDate2 As Date ' Alias of Date2 +Const cstThisSub = "Basic.DateDiff" +Const cstSubArgs = "add, date1, date2, [weekstart=1], [yearstart=1]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + lDiff = 0 + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If VarType(Date1) = V_OBJECT Then + vDate1 = CDateFromUnoDateTime(Date1) + Else + vDate1 = SF_Utils._CStrToDate(Date1) + End If + If VarType(Date2) = V_OBJECT Then + vDate2 = CDateFromUnoDateTime(Date2) + Else + vDate2 = SF_Utils._CStrToDate(Date2) + End If + lDiff = DateDiff(Add, vDate1, vDate2, WeekStart, YearStart) + + +Finally: + PyDateDiff = lDiff + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyDateDiff + +REM ----------------------------------------------------------------------------- +Public Function PyDatePart(ByVal Add As Variant _ + , ByVal DateArg As Variant _ + , ByVal WeekStart As Variant _ + , ByVal YearStart As Variant _ + ) As Long +''' Convenient function to replicate DatePart() in Python scripts +''' Args: +''' Add: The unit of the date interval +''' DateArg: The date from which to extract a part +''' WeekStart: the starting day of a week +''' YearStart: the starting week of a year +''' Returns: +''' The specified part of the date +''' Example: (Python code) +''' a = bas.DatePart('y', bas.Now()) ' day of year + +Dim lPart As Long ' Return value +Dim vDate As Date ' Alias of DateArg +Const cstThisSub = "Basic.DatePart" +Const cstSubArgs = "add, datearg, [weekstart=1], [yearstart=1]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + lPart = 0 + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If VarType(DateArg) = V_OBJECT Then + vDate = CDateFromUnoDateTime(DateArg) + Else + vDate = SF_Utils._CStrToDate(DateArg) + End If + lPart = DatePart(Add, vDate, WeekStart, YearStart) + + +Finally: + PyDatePart = lPart + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyDatePart + +REM ----------------------------------------------------------------------------- +Public Function PyDateValue(ByVal DateArg As Variant) As Variant +''' Convenient function to replicate DateValue() in Python scripts +''' Args: +''' DateArg: a date as a string +''' Returns: +''' The converted date as a UNO DateTime structure +''' Example: (Python code) +''' a = bas.DateValue('2021-02-18') + +Dim vDate As Variant ' Return value +Const cstThisSub = "Basic.DateValue" +Const cstSubArgs = "datearg" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vDate = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + vDate = DateValue(DateArg) + +Finally: + If VarType(vDate) = V_DATE Then PyDateValue = CDateToUnoDateTime(vDate) Else PyDateValue = vDate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyDateValue + +REM ----------------------------------------------------------------------------- +Public Function PyFormat(ByVal Value As Variant _ + , ByVal Pattern As Variant _ + ) As String +''' Convenient function to replicate Format() in Python scripts +''' Args: +''' Value: a date or a number +''' Pattern: the format to apply +''' Returns: +''' The formatted value +''' Example: (Python code) +''' MsgBox bas.Format(6328.2, '##,##0.00') + +Dim sFormat As String ' Return value +Dim vValue As Variant ' Alias of Value +Const cstThisSub = "Basic.Format" +Const cstSubArgs = "value, pattern" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sFormat = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If VarType(Value) = V_OBJECT Then vValue = CDateFromUnoDateTime(Value) ELse vValue = Value + If IsEmpty(Pattern) Or Len(Pattern) = 0 Then sFormat = Str(vValue) Else sFormat = Format(vValue, Pattern) + + +Finally: + PyFormat = sFormat + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyFormat + +REM ----------------------------------------------------------------------------- +Public Function PyGetGuiType() As Integer +''' Convenient function to replicate GetGuiType() in Python scripts +''' Args: +''' Returns: +''' The GetGuiType value +''' Example: (Python code) +''' MsgBox bas.GetGuiType() + +Const cstThisSub = "Basic.GetGuiType" +Const cstSubArgs = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + PyGetGuiType = GetGuiType() + + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_PythonHelper.PyGetGuiType + +REM ----------------------------------------------------------------------------- +Public Function PyGetSystemTicks() As Long +''' Convenient function to replicate GetSystemTicks() in Python scripts +''' Args: +''' Returns: +''' The GetSystemTicks value +''' Example: (Python code) +''' MsgBox bas.GetSystemTicks() + +Const cstThisSub = "Basic.GetSystemTicks" +Const cstSubArgs = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + PyGetSystemTicks = GetSystemTicks() + + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_PythonHelper.PyGetSystemTicks + +REM ----------------------------------------------------------------------------- +Public Function PyGlobalScope(ByVal Library As Variant) As Object +''' Convenient function to replicate GlobalScope() in Python scripts +''' Args: +''' Library: "Basic" or "Dialog" +''' Returns: +''' The GlobalScope value +''' Example: (Python code) +''' MsgBox bas.GlobalScope.BasicLibraries() + +Const cstThisSub = "Basic.GlobalScope.BasicLibraries" ' or DialogLibraries +Const cstSubArgs = "" + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + Select Case Library + Case "Basic" + PyGlobalScope = GlobalScope.BasicLibraries() + Case "Dialog" + PyGlobalScope = GlobalScope.DialogLibraries() + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_PythonHelper.PyGlobalScope + +REM ----------------------------------------------------------------------------- +Public Function PyInputBox(ByVal Msg As Variant _ + , ByVal Title As Variant _ + , ByVal Default As Variant _ + , Optional ByVal XPosTwips As Variant _ + , Optional ByVal YPosTwips As Variant _ + ) As String +''' Convenient function to replicate InputBox() in Python scripts +''' Args: +''' Msg: String expression displayed as the message in the dialog box +''' Title: String expression displayed in the title bar of the dialog box +''' Default: String expression displayed in the text box as default if no other input is given +''' XPosTwips: Integer expression that specifies the horizontal position of the dialog +''' YPosTwips: Integer expression that specifies the vertical position of the dialog +''' If XPosTwips and YPosTwips are omitted, the dialog is centered on the screen +''' The position is specified in twips. +''' Returns: +''' The entered value or "" if the user pressed the Cancel button +''' Example: (Python code) +''' a = bas.InputBox ('Please enter a phrase:', 'Dear User') + +Dim sInput As String ' Return value +Const cstThisSub = "Basic.InputBox" +Const cstSubArgs = "msg, [title=''], [default=''], [xpostwips], [ypostwips]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sInput = "" + +Check: + If IsMissing(YPosTwips) Then YPosTwips = 1 + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If IsMissing(XPosTwips) Then + sInput = InputBox(Msg, Title, Default) + Else + sInput = InputBox(Msg, Title, Default, XPosTwips, YPosTwips) + End If + +Finally: + PyInputBox = sInput + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyInputBox + +REM ----------------------------------------------------------------------------- +Public Function PyMsgBox(ByVal Text As Variant _ + , ByVal DialogType As Variant _ + , ByVal DialogTitle As Variant _ + ) As Integer +''' Convenient function to replicate MsgBox() in Python scripts +''' Args: +''' Text: String expression displayed as a message in the dialog box +''' DialogType: Any integer expression that defines the number and type of buttons or icons displayed +''' DialogTitle: String expression displayed in the title bar of the dialog +''' Returns: +''' The pressed button +''' Example: (Python code) +''' a = bas.MsgBox ('Please press a button:', bas.MB_EXCLAMATION, 'Dear User') + +Dim iMsg As Integer ' Return value +Const cstThisSub = "Basic.MsgBox" +Const cstSubArgs = "text, [dialogtype=0], [dialogtitle]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iMsg = -1 + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + iMsg = MsgBox(Text, DialogType, DialogTitle) + +Finally: + PyMsgBox = iMsg + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper.PyMsgBox + +REM ============================================================= PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Public Function _PythonDispatcher(ByRef BasicObject As Variant _ + , ByVal CallType As Variant _ + , ByVal Script As Variant _ + , ParamArray Args() As Variant _ + ) As Variant +''' Called from Python only +''' The method calls the method Script associated with the BasicObject class or module +''' with the given arguments +''' The invocation of the method can be a Property Get, Property Let or a usual call +''' NB: arguments and return values must not be 2D arrays +''' The implementation intends to be as AGNOSTIC as possible in terms of objects nature and methods called +''' Args: +''' BasicObject: a module or a class instance - May also be the reserved string: "SF_Services" +''' CallType: one of the constants applicable to a CallByName statement + optional protocol flags +''' Script: the name of the method or property +''' Args: the arguments to pass to the method. Input arguments can contain symbolic constants for Null, Missing, etc. +''' Returns: +''' A 1D array: +''' [0] The returned value - scalar, object or 1D array +''' [1] The VarType() of the returned value +''' Null, Empty and Nothing have different vartypes but return all None to Python +''' Additionally, when array: +''' [2] Number of dimensions in Basic +''' Additionally, when Basic object: +''' [2] Module (1), Class instance (2) or UNO (3) +''' [3] The object's ObjectType +''' [4] The object's service name +''' [5] The object's name +''' When an error occurs Python receives None as a scalar. This determines the occurrence of a failure + +Dim vReturn As Variant ' The value returned by the invoked property or method +Dim vReturnArray As Variant ' Return value +Dim vBasicObject As Variant ' Alias of BasicObject to avoid "Object reference not set" error +Dim iNbArgs As Integer ' Number of valid input arguments +Dim vArg As Variant ' Alias for a single argument +Dim vArgs() As Variant ' Alias for Args() +Dim sScript As String ' Argument of ExecuteBasicScript() +Dim vParams As Variant ' Array of arguments to pass to a ParamArray +Dim sObjectType As String ' Alias of object.ObjectType +Dim sServiceName As String ' Alias of BasicObject.ServiceName +Dim bBasicClass As Boolean ' True when BasicObject is a class +Dim sLibrary As String ' Library where the object belongs to +Dim bUno As Boolean ' Return value is a UNO object +Dim oObjDesc As Object ' _ObjectDescriptor type +Dim iDims As Integer ' # of dims of vReturn +Dim sess As Object : Set sess = ScriptForge.SF_Session +Dim i As Long, j As Long + +' Conventional special input or output values +Const cstNoArgs = "+++NOARGS+++", cstSymEmpty = "+++EMPTY+++", cstSymNull = "+++NULL+++", cstSymMissing = "+++MISSING+++" + +' https://support.office.com/en-us/article/CallByName-fonction-49ce9475-c315-4f13-8d35-e98cfe98729a +' Determines the CallType +Const vbGet = 2, vbLet = 4, vbMethod = 1, vbSet = 8 +' Protocol flags +Const cstDateArg = 64 ' May contain a date argument +Const cstDateRet = 128 ' Return value can be a date +Const cstUno = 256 ' Return value can be a UNO object +Const cstArgArray = 512 ' Any argument can be a 2D array +Const cstRetArray = 1024 ' Return value can be an array +Const cstObject = 2048 ' 1st argument is a Basic object when numeric +Const cstHardCode = 4096 ' Method must not be executed with CallByName() +' Object nature in returned array +Const objMODULE = 1, objCLASS = 2, objUNO = 3 + +Check: + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + _PythonDispatcher = Null + + ' Ignore Null basic objects (Null = Null or Nothing) + If IsNull(BasicObject) Or IsEmpty(BasicObject) Then GoTo Catch + + ' Reinterpret arguments one by one into vArgs, convert UNO date/times and conventional NoArgs/Empty/Null/Missing values + iNbArgs = -1 + vArgs = Array() + + If UBound(Args) >= 0 Then + For i = 0 To UBound(Args) + vArg = Args(i) + ' Are there arguments ? + If i = 0 And VarType(vArg) = V_STRING Then + If vArg = cstNoArgs Then Exit For + End If + ' Is 1st argument a reference to a Basic object ? + If i = 0 And (( CallType And cstObject ) = cstObject) And SF_Utils._VarTypeExt(vArg) = V_NUMERIC Then + If vArg < 0 Or Not IsArray(_SF_.PythonStorage) Then GoTo Catch + If vArg > UBound(_SF_.PythonStorage) Then GoTo Catch + vArg = _SF_.PythonStorage(vArg) + ' Is argument a symbolic constant for Null, Empty, ... , or a date? + ElseIf VarType(vArg) = V_STRING Then + If Len(vArg) = 0 Then + ElseIf vArg = cstSymEmpty Then + vArg = Empty + ElseIf vArg = cstSymNull Then + vArg = Null + ElseIf vArg = cstSymMissing Then + Exit For ' Next arguments must be missing also + End If + ElseIf VarType(vArg) = V_OBJECT Then + If ( CallType And cstDateArg ) = cstDateArg Then vArg = CDateFromUnoDateTime(vArg) + End If + iNbArgs = iNbArgs + 1 + + ReDim Preserve vArgs(iNbArgs) + vArgs(iNbArgs) = vArg + Next i + End If + +Try: + ' Dispatching strategy: based on next constraints + ' (1) Bug https://bugs.documentfoundation.org/show_bug.cgi?id=138155 + ' The CallByName function fails when returning an array + ' (2) Python has tuples and tuple of tuples, not 2D arrays + ' (3) Passing 2D arrays through a script provider always transform it into a sequence of sequences + ' (4) The CallByName function takes exclusive control on the targeted object up to its exit + ' 1. Methods in usual modules are called by ExecuteBasicScript() except if they use a ParamArray + ' 2. Properties in any service are got and set with obj.GetProperty/SetProperty(...) + ' 3. Methods in class modules are invoked with CallByName + ' 4. Methods in class modules using a 2D array or returning arrays, or methods using ParamArray, +''' are hardcoded as exceptions or are not implemented + ' 5. Due to constraint (4), a predefined list of method calls must be hardcoded to avoid blocking use of CallByName + ' The concerned methods are flagged with cstHardCode + + With _SF_ + ' Initialize Python persistent storage at 1st call + If IsEmpty(.PythonStorage) Then ._InitPythonStorage() + ' Reset any error + ._Stackreset() + ' Set Python trigger to manage signatures in error messages + .TriggeredByPython = True + End With + + Select case VarType(BasicObject) + Case V_STRING + ' Special entry for CreateScriptService() + vBasicObject = BasicObject + If vBasicObject = "SF_Services" Then + If UBound(vArgs) = 0 Then vParams = Array() Else vParams = SF_Array.Slice(vArgs, 1) + Select Case UBound(vParams) + Case -1 : vReturn = SF_Services.CreateScriptService(vArgs(0)) + Case 0 : vReturn = SF_Services.CreateScriptService(vArgs(0), vParams(0)) + Case 1 : vReturn = SF_Services.CreateScriptService(vArgs(0), vParams(0), vParams(1)) + Case 2 : vReturn = SF_Services.CreateScriptService(vArgs(0), vParams(0), vParams(1), vParams(2)) + Case 3 : vReturn = SF_Services.CreateScriptService(vArgs(0), vParams(0), vParams(1), vParams(2), vParams(3)) + Case 4 : vReturn = SF_Services.CreateScriptService(vArgs(0), vParams(0), vParams(1), vParams(2), vParams(3), vParams(4)) + End Select + End If + If VarType(vReturn) = V_OBJECT And Not IsNull(vReturn) Then + vBasicObject = vReturn + sObjectType = vBasicObject.ObjectType + bBasicClass = ( Left(sObjectType, 3) <> "SF_" ) + End If + + ' Implement dispatching strategy + Case V_INTEGER + If BasicObject < 0 Or Not IsArray(_SF_.PythonStorage) Then GoTo Catch + If BasicObject > UBound(_SF_.PythonStorage) Then GoTo Catch + vBasicObject = _SF_.PythonStorage(BasicObject) + sObjectType = vBasicObject.ObjectType + sServiceName = vBasicObject.ServiceName + + ' Basic modules have type = "SF_*" + bBasicClass = ( Left(sObjectType, 3) <> "SF_" ) + sLibrary = Split(sServiceName, ".")(0) + + ' Methods in standard modules returning/passing a date are hardcoded as exceptions + If Not bBasicClass And ((CallType And vbMethod) = vbMethod) _ + And (((CallType And cstDateRet) = cstDateRet) Or ((CallType And cstDateArg) = cstDateArg)) Then + Select Case sServiceName + Case "ScriptForge.FileSystem" + If Script = "GetFileModified" Then vReturn = SF_FileSystem.GetFileModified(vArgs(0)) + Case "ScriptForge.Region" + Select Case Script + Case "DSTOffset" : vReturn = SF_Region.DSTOffset(vArgs(0), vArgs(1), vArgs(2)) + Case "LocalDateTime" : vReturn = SF_Region.LocalDateTime(vArgs(0), vArgs(1), vArgs(2)) + Case "UTCDateTime" : vReturn = SF_Region.UTCDateTime(vArgs(0), vArgs(1), vArgs(2)) + Case "UTCNow" : vReturn = SF_Region.UTCNow(vArgs(0), vArgs(1)) + Case Else + End Select + End Select + + ' Methods in usual modules using a 2D array or returning arrays are hardcoded as exceptions + ElseIf Not bBasicClass And _ + (((CallType And vbMethod) + (CallType And cstArgArray)) = vbMethod + cstArgArray Or _ + ((CallType And vbMethod) + (CallType And cstRetArray)) = vbMethod + cstRetArray) Then + ' Not service related + If Script = "Methods" Then + vReturn = vBasicObject.Methods() + ElseIf Script = "Properties" Then + vReturn = vBasicObject.Properties() + Else + Select Case sServiceName + Case "ScriptForge.Array" + If Script = "ImportFromCSVFile" Then vReturn = SF_Array.ImportFromCSVFile(vArgs(0), vArgs(1), vArgs(2), True) + End Select + End If + + ' Methods in usual modules are called by ExecuteBasicScript() except if they use a ParamArray + ElseIf Not bBasicClass And (CallType And vbMethod) = vbMethod Then + sScript = sLibrary & "." & sObjectType & "." & Script + ' Force validation in targeted function, not in ExecuteBasicScript() + _SF_.StackLevel = -1 + Select Case UBound(vArgs) + Case -1 : vReturn = sess.ExecuteBasicScript(, sScript) + Case 0 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0)) + Case 1 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1)) + Case 2 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1), vArgs(2)) + Case 3 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case 4 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + Case 5 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5)) + Case 6 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case 7 : vReturn = sess.ExecuteBasicScript(, sScript, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7)) + End Select + _SF_.StackLevel = 0 + + ' Properties in any service are got and set with obj.GetProperty/SetProperty(...) + ElseIf (CallType And vbGet) = vbGet Then ' In some cases (Calc ...) GetProperty may have an argument + If UBound(vArgs) < 0 Then vReturn = vBasicObject.GetProperty(Script) Else vReturn = vBasicObject.GetProperty(Script, vArgs(0)) + ElseIf (CallType And vbLet) = vbLet Then + vReturn = vBasicObject.SetProperty(Script, vArgs(0)) + + ' Methods in class modules using a 2D array or returning arrays are hardcoded as exceptions. Bug #138155 + ElseIf ((CallType And vbMethod) + (CallType And cstArgArray)) = vbMethod + cstArgArray Or _ + ((CallType And vbMethod) + (CallType And cstRetArray)) = vbMethod + cstRetArray Then + If Script = "Methods" Then + vReturn = vBasicObject.Methods() + ElseIf Script = "Properties" Then + vReturn = vBasicObject.Properties() + Else + Select Case sServiceName + Case "SFDatabases.Database" + If Script = "GetRows" Then vReturn = vBasicObject.GetRows(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case "SFDialogs.Dialog" + If Script = "Controls" Then vReturn = vBasicObject.Controls(vArgs(0)) + Case "SFDialogs.DialogControl" + If Script = "SetTableData" Then vReturn = vBasicObject.SetTableData(vArgs(0), vArgs(1), vArgs(2)) + Case "SFDocuments.Document" + If Script = "Forms" Then vReturn = vBasicObject.Forms(vArgs(0)) + Case "SFDocuments.Base" + Select Case Script + Case "FormDocuments" : vReturn = vBasicObject.FormDocuments() + Case "Forms" : vReturn = vBasicObject.Forms(vArgs(0), vArgs(1)) + End Select + Case "SFDocuments.Calc" + Select Case Script + Case "Charts" : vReturn = vBasicObject.Charts(vArgs(0), vArgs(1)) + Case "Forms" : vReturn = vBasicObject.Forms(vArgs(0), vArgs(1)) + Case "GetFormula" : vReturn = vBasicObject.GetFormula(vArgs(0)) + Case "GetValue" : vReturn = vBasicObject.GetValue(vArgs(0)) + Case "SetArray" : vReturn = vBasicObject.SetArray(vArgs(0), vArgs(1)) + Case "SetFormula" : vReturn = vBasicObject.SetFormula(vArgs(0), vArgs(1)) + Case "SetValue" : vReturn = vBasicObject.SetValue(vArgs(0), vArgs(1)) + End Select + Case "SFDocuments.Form" + Select Case Script + Case "Controls" : vReturn = vBasicObject.Controls(vArgs(0)) + Case "Subforms" : vReturn = vBasicObject.Subforms(vArgs(0)) + End Select + Case "SFDocuments.FormControl" + If Script = "Controls" Then vReturn = vBasicObject.Controls(vArgs(0)) + End Select + End If + + ' Methods in class modules may better not be executed with CallByName() + ElseIf bBasicClass And ((CallType And vbMethod) + (CallType And cstHardCode)) = vbMethod + cstHardCode Then + Select Case sServiceName + Case "SFDialogs.Dialog" + Select Case Script + Case "Activate" : vReturn = vBasicObject.Activate() + Case "Center" + If UBound(vArgs) < 0 Then vReturn = vBasicObject.Center() Else vReturn = vBasicObject.Center(vArgs(0)) + Case "EndExecute" : vReturn = vBasicObject.EndExecute(vArgs(0)) + Case "Execute" : vReturn = vBasicObject.Execute(vArgs(0)) + Case "Resize" : vReturn = vBasicObject.Resize(vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + End Select + End Select + + ' Methods in class modules are invoked with CallByName + ElseIf bBasicClass And ((CallType And vbMethod) = vbMethod) Then + Select Case UBound(vArgs) + ' Dirty alternatives to process usual and ParamArray cases + ' But, up to ... how many ? + ' - The OFFSETADDRESSERROR has 12 arguments + ' - The ".uno:DataSort" command may have 14 property name-value pairs + Case -1 : vReturn = CallByName(vBasicObject, Script, vbMethod) + Case 0 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0)) + Case 1 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1)) + Case 2 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2)) + Case 3 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3)) + Case 4 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4)) + Case 5 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5)) + Case 6 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6)) + Case 7 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7)) + Case 8 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8)) + Case 9 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9)) + Case 10 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10)) + Case 11 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11)) + Case 12, 13 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12)) + Case 14, 15 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14)) + Case 16, 17 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16)) + Case 18, 19 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16), vArgs(17), vArgs(18)) + Case 20, 21 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16), vArgs(17), vArgs(18) _ + , vArgs(19), vArgs(20)) + Case 22, 23 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16), vArgs(17), vArgs(18) _ + , vArgs(19), vArgs(20), vArgs(21), vArgs(22)) + Case 24, 25 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16), vArgs(17), vArgs(18) _ + , vArgs(19), vArgs(20), vArgs(21), vArgs(22), vArgs(23), vArgs(24)) + Case 26, 27 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16), vArgs(17), vArgs(18) _ + , vArgs(19), vArgs(20), vArgs(21), vArgs(22), vArgs(23), vArgs(24), vArgs(25), vArgs(26)) + Case >= 28 : vReturn = CallByName(vBasicObject, Script, vbMethod, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7) _ + , vArgs(8), vArgs(9), vArgs(10), vArgs(11), vArgs(12), vArgs(13), vArgs(14), vArgs(15), vArgs(16), vArgs(17), vArgs(18) _ + , vArgs(19), vArgs(20), vArgs(21), vArgs(22), vArgs(23), vArgs(24), vArgs(25), vArgs(26), vArgs(27), vArgs(28)) + End Select + End If + + ' Post processing + If Script = "Dispose" Then + ' Special case: Dispose() must update the cache for class objects created in Python scripts + Set _SF_.PythonStorage(BasicObject) = Nothing + End If + Case Else + End Select + + ' Format the returned array + vReturnArray = Array() + ' Distinguish: Basic object + ' UNO object + ' Array + ' Scalar + If IsArray(vReturn) Then + ReDim vReturnArray(0 To 2) + iDims = SF_Array.CountDims(vReturn) + ' Replace dates by UNO format + If iDims = 1 Then + For i = LBound(vReturn) To UBound(vReturn) + If VarType(vReturn(i)) = V_DATE Then vReturn(i) = CDateToUnoDateTime(vReturn(i)) + Next i + ElseIf iDims = 2 Then + For i = LBound(vReturn, 1) To UBound(vReturn, 1) + For j = LBound(vReturn, 2) To UBound(vReturn, 2) + If VarType(vReturn(i, j)) = V_DATE Then vReturn(i, j) = CDateToUnoDateTime(vReturn(i, j)) + Next j + Next i + End If + vReturnArray(0) = vReturn ' 2D arrays are flattened by the script provider when returning to Python + vReturnArray(1) = VarType(vReturn) + vReturnArray(2) = iDims + ElseIf VarType(vReturn) = V_OBJECT And Not IsNull(vReturn) Then + ' Uno or not Uno ? + bUno = False + If (CallType And cstUno) = cstUno Then ' UNO considered only when pre-announced in CallType + Set oObjDesc = SF_Utils._VarTypeObj(vReturn) + bUno = ( oObjDesc.iVarType = V_UNOOBJECT ) + End If + If bUno Then + ReDim vReturnArray(0 To 2) + Set vReturnArray(0) = vReturn + Else + ReDim vReturnArray(0 To 5) + vReturnArray(0) = _SF_._AddToPythonSTorage(vReturn) + End If + vReturnArray(1) = V_OBJECT + vReturnArray(2) = Iif(bUno, objUNO, Iif(bBasicClass, objCLASS, objMODULE)) + If Not bUno Then + vReturnArray(3) = vReturn.ObjectType + vReturnArray(4) = vReturn.ServiceName + vReturnArray(5) = "" + If vReturn.ObjectType <> "SF_CalcReference" Then ' Calc references are implemented as a Type ... End Type data structure + If SF_Array.Contains(vReturn.Properties(), "Name", SortOrder := "ASC") Then vReturnArray(5) = vReturn.Name + End If + End If + Else ' Scalar or Nothing + ReDim vReturnArray(0 To 1) + If VarType(vReturn) = V_DATE Then vReturnArray(0) = CDateToUnoDateTime(vReturn) Else vReturnArray(0) = vReturn + vReturnArray(1) = VarType(vReturn) + End If + + _PythonDispatcher = vReturnArray + +Finally: + _SF_.TriggeredByPython = False ' Reset normal state + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_PythonHelper._PythonDispatcher + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Basic instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[PythonHelper]" + + _Repr = "[PythonHelper]" + +End Function ' ScriptForge.SF_PythonHelper._Repr + +REM ================================================= END OF SCRIPTFORGE.SF_PythonHelper + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Region.xba b/wizards/source/scriptforge/SF_Region.xba new file mode 100644 index 000000000..d3eacfae0 --- /dev/null +++ b/wizards/source/scriptforge/SF_Region.xba @@ -0,0 +1,861 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Region +''' ========= +''' Singleton class implementing the "ScriptForge.Region" service +''' Implemented as a usual Basic module +''' +''' A collection of functions about languages, countries and timezones +''' - Locales +''' - Currencies +''' - Numbers and dates formatting +''' - Calendars +''' - Timezones conversions +''' - Numbers transformed to text +''' +''' Definitions: +''' Locale or Region +''' A combination of a language (2 or 3 lower case characters) and a country (2 upper case characters) +''' Most properties and methods require a locale as argument. +''' Some of them accept either the complete locale or only the language or country parts. +''' When absent, the considered locale is the locale used in the LibreOffice user interface. +''' (see the SF_Platform.OfficeLocale property) +''' Timezone +''' Specified as "Region/City" name like "Europe/Berlin", or a custom time zone ID such as "UTC" or "GMT-8:00". +''' The time offset between the timezone and the Greenwich Meridian Time (GMT) is expressed in minutes. +''' The Daylight Saving Time (DST) is an additional offset. +''' Both offsets can be positive or negative. +''' More info on +''' https://timezonedb.com/time-zones +''' https://en.wikipedia.org/wiki/Time_zone +''' +''' Service invocation example: +''' Dim regio As Object +''' Set regio = CreateScriptService("Region") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_region.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ============================================================= PRIVATE MEMBERS + +Private UserLocale As String ' platform.OfficeLocale + +' Reference tables +Private LocaleData As Variant ' com.sun.star.i18n.LocaleData +Private LocaleNames As Variant ' Array of all available "la-CO" strings + +Private UserIndex As Integer ' Index of UserLocale in reference tables + +REM ============================================================ MODULE CONSTANTS + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_Region Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Country(Optional ByVal Region As Variant) As String +''' Returns the english country name applicable in the given region. +''' The region expressed either as a +''' - locale combining language-COUNTRY (la-CO) +''' - country only (CO) +''' Example: +''' MsgBox Regio.Country("IT") ' Italy + Country = _PropertyGet("Country", Region) +End Property ' ScriptForge.SF_Region.Country (get) + +REM ----------------------------------------------------------------------------- +Property Get Currency(Optional ByVal Region As Variant) As String +''' Returns the currency applicable in the given region. +''' The region is expressed either as a +''' - locale combining language-COUNTRY (la-CO) +''' - country only (CO) +''' Example: +''' MsgBox Regio.Currency("IT") ' EUR + Currency = _PropertyGet("Currency", Region) +End Property ' ScriptForge.SF_Region.Currency (get) + +REM ----------------------------------------------------------------------------- +Public Function DatePatterns(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of date acceptance patterns for the given region. +''' Patterns with input combinations that are accepted as incomplete date input, such as M/D or D.M +''' The region is expressed as a locale combining language-COUNTRY (la-CO) +''' The list is zero-based. +''' Example: +''' MsgBox Join(Regio.DatePatterns("it-IT"), ",") ' D/M/Y,D/M + DatePatterns = _PropertyGet("DatePatterns", Region) +End Function ' ScriptForge.SF_Region.DatePatterns (get) + +REM ----------------------------------------------------------------------------- +Property Get DateSeparator(Optional ByVal Region As Variant) As String +''' Returns the separator used in dates applicable in the given region. +''' The region is expressed as a locale combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox Regio.DateSeparator("it-IT") ' / + DateSeparator = _PropertyGet("DateSeparator", Region) +End Property ' ScriptForge.SF_Region.DateSeparator (get) + +REM ----------------------------------------------------------------------------- +Public Function DayAbbrevNames(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of abbreviated names of weekdays applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' The list is zero-based. The 1st in the list [0] is the Monday. +''' Example: +''' MsgBox Join(Regio.DayAbbrevNames("it-IT"), ",") ' lun,mar,mer,gio,ven,sab,dom + DayAbbrevNames = _PropertyGet("DayAbbrevNames", Region) +End Function ' ScriptForge.SF_Region.DayAbbrevNames (get) + +REM ----------------------------------------------------------------------------- +Public Function DayNames(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of names of weekdays applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' The list is zero-based. The 1st in the list [0] is the Monday. +''' Example: +''' MsgBox Join(Regio.DayNames("it-IT"), ",") ' lunedì,martedì,mercoledì,giovedì,venerdì,sabato,domenica + DayNames = _PropertyGet("DayNames", Region) +End Function ' ScriptForge.SF_Region.DayNames (get) + +REM ----------------------------------------------------------------------------- +Public Function DayNarrowNames(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of initials of weekdays applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' The list is zero-based. The 1st in the list [0] is the Monday. +''' Example: +''' MsgBox Join(Regio.DayNarrowNames("it-IT"), ",") ' l,m,m,g,v,s,d + DayNarrowNames = _PropertyGet("DayNarrowNames", Region) +End Function ' ScriptForge.SF_Region.DayNarrowNames (get) + +REM ----------------------------------------------------------------------------- +Property Get DecimalPoint(Optional ByVal Region As Variant) As String +''' Returns the decimal separator used in numbers applicable in the given region. +''' The region is expressed as a locale combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox Regio.DecimalPoint("it-IT") ' . + DecimalPoint = _PropertyGet("DecimalPoint", Region) +End Property ' ScriptForge.SF_Region.DecimalPoint (get) + +REM ----------------------------------------------------------------------------- +Property Get Language(Optional ByVal Region As Variant) As String +''' Returns the english Language name applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' Example: +''' MsgBox Regio.Language("it-IT") ' Italian + Language = _PropertyGet("Language", Region) +End Property ' ScriptForge.SF_Region.Language (get) + +REM ----------------------------------------------------------------------------- +Property Get ListSeparator(Optional ByVal Region As Variant) As String +''' Returns the separator used in lists applicable in the given region. +''' The region is expressed as a locale combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox Regio.ListSeparator("it-IT") ' ; + ListSeparator = _PropertyGet("ListSeparator", Region) +End Property ' ScriptForge.SF_Region.ListSeparator (get) + +REM ----------------------------------------------------------------------------- +Public Function MonthAbbrevNames(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of abbreviated names of months applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' The list is zero-based. +''' Example: +''' MsgBox Join(Regio.MonthAbbrevNames("it-IT"), ",") ' gen,feb,mar,apr,mag,giu,lug,ago,set,ott,nov,dic + MonthAbbrevNames = _PropertyGet("MonthAbbrevNames", Region) +End Function ' ScriptForge.SF_Region.MonthAbbrevNames (get) + +REM ----------------------------------------------------------------------------- +Public Function MonthNames(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of names of months applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' The list is zero-based. +''' Example: +''' MsgBox Join(Regio.MonthNames("it-IT"), ",") ' gennaio,febbraio,marzo,aprile,maggio,giugno,luglio,agosto,settembre,ottobre,novembre,dicembre + MonthNames = _PropertyGet("MonthNames", Region) +End Function ' ScriptForge.SF_Region.MonthNames (get) + +REM ----------------------------------------------------------------------------- +Public Function MonthNarrowNames(Optional ByVal Region As Variant) As Variant ' Function better than Property when return value is an array +''' Returns list of initials of months applicable in the given region. +''' The region expressed as a +''' - locale combining language-COUNTRY (la-CO) +''' - language only (la) +''' The list is zero-based. +''' Example: +''' MsgBox Join(Regio.MonthNarrowNames("it-IT"), ",") ' g,f,m,a,m,g,l,a,s,o,n,d + MonthNarrowNames = _PropertyGet("MonthNarrowNames", Region) +End Function ' ScriptForge.SF_Region.MonthNarrowNames (get) + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_Region" +End Property ' ScriptForge.SF_Region.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.Region" +End Property ' ScriptForge.SF_Region.ServiceName + +REM ----------------------------------------------------------------------------- +Property Get ThousandSeparator(Optional ByVal Region As Variant) As String +''' Returns the thousands separator used in numbers applicable in the given region. +''' The region is expressed as a locale combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox Regio.ThousandSeparator("it-IT") ' . + ThousandSeparator = _PropertyGet("ThousandSeparator", Region) +End Property ' ScriptForge.SF_Region.ThousandSeparator (get) + +REM ----------------------------------------------------------------------------- +Property Get TimeSeparator(Optional ByVal Region As Variant) As String +''' Returns the separator used to format times applicable in the given region. +''' The region is expressed as a locale combining language-COUNTRY (la-CO) +''' Example: +''' MsgBox Regio.TimeSeparator("it-IT") ' : + TimeSeparator = _PropertyGet("TimeSeparator", Region) +End Property ' ScriptForge.SF_Region.TimeSeparator (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function DSTOffset(Optional ByVal LocalDateTime As Variant _ + , Optional ByVal TimeZone As Variant _ + , Optional ByVal Locale As Variant _ + ) As Integer +''' Computes the additional offset due to daylight saving ("summer time") +''' Args +''' LocalDateTime: local date and time as a Date. DST offset varies during the year. +''' TimeZone: specified as "Region/City" name like "Europe/Berlin", or a custom time zone ID such as "UTC" or "GMT-8:00" +''' Locale: expressed as a locale combining language-COUNTRY (la-CO), or COUNTRY alone (CO) +''' Return: +''' The offset in minutes +''' Examples: +''' regio.DSTOffset(DateSerial(2022, 8, 20) + TimeSerial(16, 58, 17), "Europe/Brussels", "fr-BE") ' 60 + +Dim iDSTOffset As Integer ' Return value +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oCalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Const cstThisSub = "Region.DSTOffset" +Const cstSubArgs = "LocalDateTime, TimeZone, [Locale=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iDSTOffset = 0 + +Check: + If IsMissing(Locale) Or IsEmpty(Locale) Then Locale = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(LocalDateTime, "LocalDateTime", V_DATE) Then GoTo Finally + If Not SF_Utils._Validate(TimeZone, "TimeZone", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Locale, "Locale", V_STRING) Then GoTo Finally + End If + + Set oLocale = SF_Region._GetLocale(Locale, pbCountry := True) + If IsNull(oLocale) Then GoTo Finally + +Try: + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendarTZ(oLocale, TimeZone) + .setLocalDateTime(LocaldateTime) + iDSTOffset = .getValue(com.sun.star.i18n.CalendarFieldIndex.DST_OFFSET) + End With + +Finally: + DSTOffset = iDSTOffset + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.DSTOffset + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant _ + , Optional Region As Variant _ + ) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Region: the language-COUNTRY combination (la-CO) or the country (CO- or the language (la) +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Region.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If IsMissing(Region) Or IsEmpty(Region) Then Region = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Region, "Region", V_STRING) Then GoTo Catch + End If + +Try: + If Len(Region) = 0 Then + GetProperty = _PropertyGet(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName, Region) + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function LocalDateTime(Optional ByVal UTCDateTime As Variant _ + , Optional ByVal TimeZone As Variant _ + , Optional ByVal Locale As Variant _ + ) As Date +''' Computes the local date and time from a UTC date and time +''' Args +''' UTCDateTime: the universal date and time to be converted to local time +''' TimeZone: specified as "Region/City" name like "Europe/Berlin", or a custom time zone ID such as "UTC" or "GMT-8:00" +''' Locale: expressed as a locale combining language-COUNTRY (la-CO), or COUNTRY alone (CO) +''' Return: +''' The local time converted from the corresponding UTC date and time as a Date +''' If the returned value is before 1900, it is likely that the Locale is not recognized +''' If the returned value matches the local time, it is likely that the timezone is not recognized +''' Examples: +''' regio.LocalDateTime(DateSerial(2022, 3, 20) + TimeSerial(16, 58, 17), "Europe/Brussels", "fr-BE") +''' ' 2022-03-20 17:58:17 + +Dim dLocalDateTime As Double ' Return value +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oCalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Const cstThisSub = "Region.LocalDateTime" +Const cstSubArgs = "UTCDateTime, TimeZone, [Locale=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + dLocalDateTime = -1 + +Check: + If IsMissing(Locale) Or IsEmpty(Locale) Then Locale = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(LocalDateTime, "LocalDateTime", V_DATE) Then GoTo Finally + If Not SF_Utils._Validate(TimeZone, "TimeZone", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Locale, "Locale", V_STRING) Then GoTo Finally + End If + + Set oLocale = SF_Region._GetLocale(Locale, pbCountry := True) + If IsNull(oLocale) Then GoTo Finally + +Try: + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendarTZ(oLocale, TimeZone) + .setDateTime(UTCDateTime) + dLocalDateTime = .getLocalDateTime() + End With + +Finally: + LocalDateTime = CDate(dLocalDateTime) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.LocalDateTime + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Region class as an array + + Methods = Array( _ + "DSTOffset" _ + , "LocalDateTime" _ + , "Number2Text" _ + , "TimeZoneOffset" _ + , "UTCDateTime" _ + , "UTCNow" _ + ) + +End Function ' ScriptForge.SF_Region.Methods + +REM ----------------------------------------------------------------------------- +Public Function Number2Text(Optional ByVal Number As Variant _ + , Optional ByVal Locale As Variant _ + ) As String +''' Convert numbers and money amounts in many languages into words +''' Args +''' Number: the number to spell out +''' Accepted types: strings or numeric values (integer or real numbers) +''' When a string, a variety of prefixes is supported +''' The string "help" provides helpful tips about allowed prefixes by language +''' Example for french +''' un, deux, trois +''' feminine: une, deux, trois +''' masculine: un, deux, trois +''' ordinal: premier, deuxième, troisième +''' ordinal-feminine: première, deuxième, troisième +''' ordinal-masculine: premier, deuxième, troisième +''' informal: onze-cents, douze-cents, treize-cents +''' Numbers may be prefixed by ISO currency codes (EUR, USD, ...) +''' Locale: expressed as a locale combining language-COUNTRY (la-CO), or language alone (la) +''' The list of supported languages can be found on +''' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1linguistic2_1_1XNumberText.html +''' Return: +''' The number or amount transformed in words +''' Examples: +''' regio.Number2Text("help", "fr") ' See above +''' regio.Number2Text("79,93", "fr-BE") ' septante-neuf virgule nonante-trois +''' regio.Number2Text(Pi(), "pt-BR") ' três vírgula um quatro um cinco nove dois seis cinco três cinco oito nove sete nove +''' regio.Number2Text("EUR 1234.56", "it") ' milleduecentotrentaquattro euro cinquantasei centesimi + +Dim sNumber2Text As String ' Return value +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oNumber2Text As Object ' com.sun.star.linguistic2.NumberText +Const cstThisSub = "Region.Number2Text" +Const cstSubArgs = "Number, [Locale=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sNumber2Text = "" + +Check: + If IsMissing(Locale) Or IsEmpty(Locale) Then Locale = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Number, "Number", Array(V_STRING, V_NUMERIC)) Then GoTo Finally + If Not SF_Utils._Validate(Locale, "Locale", V_STRING) Then GoTo Finally + End If + + Set oLocale = SF_Region._GetLocale(Locale, pbLanguage := True) + If IsNull(oLocale) Then GoTo Finally + +Try: + Set oNumber2Text = SF_Utils._GetUNOService("Number2Text") + sNumber2Text = oNumber2Text.getNumberText(Number, oLocale) + +Finally: + Number2Text = sNumber2Text + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.Number2Text + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Region class as an array + + Properties = Array( _ + "Country" _ + , "Currency" _ + , "DatePatterns" _ + , "DateSeparator" _ + , "DayAbbrevNames" _ + , "DayNames" _ + , "DayNarrowNames" _ + , "DecimalPoint" _ + , "Language" _ + , "ListSeparator" _ + , "MonthAbbrevNames" _ + , "MonthNames" _ + , "MonthNarrowNames" _ + , "ThousandSeparator" _ + , "TimeSeparator" _ + ) + +End Function ' ScriptForge.SF_Region.Properties + +REM ----------------------------------------------------------------------------- +Public Function TimeZoneOffset(Optional ByVal TimeZone As Variant _ + , Optional ByVal Locale As Variant _ + ) As Integer +''' Computes the offset between GMT and the given timezone and locale +''' Args +''' TimeZone: specified as "Region/City" name like "Europe/Berlin", or a custom time zone ID such as "UTC" or "GMT-8:00" +''' Locale: expressed as a locale combining language-COUNTRY (la-CO), or COUNTRY alone (CO) +''' Return: +''' The offset in minutes +''' Examples: +''' regio.TimeZoneOffset("Europe/Brussels", "fr-BE") ' 60 + +Dim iTimeZoneOffset As Integer ' Return value +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oCalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Const cstThisSub = "Region.TimeZoneOffset" +Const cstSubArgs = "TimeZone, [Locale=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iTimeZoneOffset = 0 + +Check: + If IsMissing(Locale) Or IsEmpty(Locale) Then Locale = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(TimeZone, "TimeZone", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Locale, "Locale", V_STRING) Then GoTo Finally + End If + + Set oLocale = SF_Region._GetLocale(Locale, pbCountry := True) + If IsNull(oLocale) Then GoTo Finally + +Try: + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendarTZ(oLocale, TimeZone) + iTimeZoneOffset = .getValue(com.sun.star.i18n.CalendarFieldIndex.ZONE_OFFSET) + End With + +Finally: + TimeZoneOffset = iTimeZoneOffset + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.TimeZoneOffset + +REM ----------------------------------------------------------------------------- +Public Function UTCDateTime(Optional ByVal LocalDateTime As Variant _ + , Optional ByVal TimeZone As Variant _ + , Optional ByVal Locale As Variant _ + ) As Date +''' Computes the UTC date and time of a given local date and time +''' Args +''' LocalDateTime: the date and time measured in a given timezone +''' TimeZone: specified as "Region/City" name like "Europe/Berlin", or a custom time zone ID such as "UTC" or "GMT-8:00" +''' Locale: expressed as a locale combining language-COUNTRY (la-CO), or COUNTRY alone (CO) +''' Return: +''' The local time converted to the corresponding UTC date and time as a Date +''' If the returned value is before 1900, it is likely that the Locale is not recognized +''' If the returned value matches the local time, it is likely that the the timezone is not recognized +''' Examples: +''' regio.UTCDateTime(DateSerial(2022, 3, 20) + TimeSerial(17, 58, 17), "Europe/Brussels", "fr-BE") +''' ' 2022-03-20 16:58:17 + +Dim dUTCDateTime As Double ' Return value +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oCalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Const cstThisSub = "Region.UTCDateTime" +Const cstSubArgs = "LocalDateTime, TimeZone, [Locale=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + dUTCDateTime = -1 + +Check: + If IsMissing(Locale) Or IsEmpty(Locale) Then Locale = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(LocalDateTime, "LocalDateTime", V_DATE) Then GoTo Finally + If Not SF_Utils._Validate(TimeZone, "TimeZone", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Locale, "Locale", V_STRING) Then GoTo Finally + End If + + Set oLocale = SF_Region._GetLocale(Locale, pbCountry := True) + If IsNull(oLocale) Then GoTo Finally + +Try: + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendarTZ(oLocale, TimeZone) + .setLocalDateTime(LocalDateTime) + dUTCDateTime = .getDateTime() + End With + +Finally: + UTCDateTime = CDate(dUTCDateTime) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.UTCDateTime + +REM ----------------------------------------------------------------------------- +Public Function UTCNow(Optional ByVal TimeZone As Variant _ + , Optional ByVal Locale As Variant _ + ) As Date +''' Computes the actual UTC date and time +''' Args +''' TimeZone: specified as "Region/City" name like "Europe/Berlin", or a custom time zone ID such as "UTC" or "GMT-8:00" +''' Locale: expressed as a locale combining language-COUNTRY (la-CO), or COUNTRY alone (CO) +''' Return: +''' The actual UTC date and time as a Date +''' If the returned value is before 1900, it is likely that the Locale is not recognized +''' If the returned value matches the local time, it is likely that the the timezone is not recognized +''' Examples: +''' regio.UTCNow("Europe/Brussels", "fr-BE") ' 2022-03-20 16:58:17 + +Dim dUTCNow As Double ' Return value +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oCalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Const cstThisSub = "Region.UTCNow" +Const cstSubArgs = "TimeZone, [Locale=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + dUTCNow = -1 + +Check: + If IsMissing(Locale) Or IsEmpty(Locale) Then Locale = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(TimeZone, "TimeZone", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Locale, "Locale", V_STRING) Then GoTo Finally + End If + + Set oLocale = SF_Region._GetLocale(Locale, pbCountry := True) + If IsNull(oLocale) Then GoTo Finally + +Try: + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendarTZ(oLocale, TimeZone) + .setLocalDateTime(Now()) + dUTCNow = .getDateTime() + End With + +Finally: + UTCNow = CDate(dUTCNow) + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Region.UTCNow + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _GetLocale(ByVal psLocale As String _ + , Optional ByVal pbCountry As Variant _ + , Optional ByVal pbLanguage As Variant _ + ) As Object +''' Convert a locale given as a string to a com.sun.star.lang.Locale object +''' Args: +''' psLocale: the input string, as "la-CO", "la" or "CO" +''' pbCountry: True when "CO" only is admitted +''' pbLanguage: True when "la" only is admitted +''' At most one out of pbLanguage or pbCountry may be True +''' Returns: +''' com.sun.star.lang.Locale + +Dim sLocale As String ' "la-CO" +Dim iLocale As Integer ' Index in reference tables +Dim oLocale As Object ' Return value com.sun.star.lang.Locale +Dim i As Integer + + If IsMissing(pbCountry) Or IsEmpty(pbCountry) Then pbCountry = False + If IsMissing(pbLanguage) Or IsEmpty(pbLanguage) Then pbLanguage = False + + _LoadAllLocales() ' Initialize locale reference tables + +Check: + ' The argument may be a language "la", a country "CO" or a Locale "la-CO" + ' Scan the reference tables to find a valid locale as a com.sun.star.lang.Locale + Set oLocale = Nothing : sLocale = "" : iLocale = -1 + If Len(psLocale) = 0 Then ' Default value is the office com.sun.star.i18n.Locale + sLocale = UserLocale + iLocale = UserIndex + ElseIf InStr(psLocale, "-") = 0 Then ' Language only or country only + Select Case True + Case pbLanguage + ' Find any locale having the argument as language + For i = 0 To UBound(LocaleNames) + ' A language is presumed 2 or 3 characters long + If Split(LocaleNames(i), "-")(0) = LCase(psLocale) Then + sLocale = LocaleNames(i) + iLocale = i + Exit For + End If + Next i + Case pbCountry + ' Find any locale having the argument as country + For i = 0 To UBound(LocaleNames) + ' A country is presumed exactly 2 characters long + If Right(LocaleNames(i), 2) = UCase(psLocale) Then + sLocale = LocaleNames(i) + iLocale = i + Exit For + End If + Next i + Case Else + End Select + Else ' A full locale is given + iLocale = SF_Array.IndexOf(LocaleNames, psLocale, CaseSensitive := False) + If iLocale >= 0 Then sLocale = LocaleNames(iLocale) + End If + +Try: + ' Build error message when relevant + If iLocale < 0 Then + If Not SF_Utils._Validate(psLocale, "Locale", V_STRING, LocaleNames) Then GoTo Finally + Else + Set oLocale = CreateUnoStruct("com.sun.star.lang.Locale") + oLocale.Language = Split(sLocale, "-")(0) ' A language is 2 or 3 characters long + oLocale.Country = Right(sLocale, 2) + End If + +Finally: + Set _GetLocale = oLocale + Exit Function +End Function ' ScriptForge.SF_Region._GetLocale + +REM ----------------------------------------------------------------------------- +Private Sub _LoadAllLocales() +''' Initialize the LocaleNames array = the list of all available locales in the LibreOffice installation + +Dim oOffice As Object ' com.sun.star.lang.Locale +Dim vLocales As Variant ' Array of com.sun.star.lang.Locale +Dim iTop As Integer ' Upper bound of LocaleNames +Dim i As Integer + +Try: + ' Office locale + If Len(UserLocale) = 0 Then + Set oOffice = SF_Utils._GetUNOService("OfficeLocale") + UserLocale = oOffice.Language & "-" & oOffice.Country + End If + + ' LocaleData, localeNames and UserIndex + If IsEmpty(LocaleData) Or IsNull(LocaleData) Or Not IsArray(LocaleNames) Then + LocaleData = SF_Utils._GetUNOService("LocaleData") + vLocales = LocaleData.getAllInstalledLocaleNames() + LocaleNames = Array() + iTop = UBound(vLocales) + ReDim LocaleNames(0 To iTop) + For i = 0 To iTop + LocaleNames(i) = vLocales(i).Language & "-" & vLocales(i).Country + If LocaleNames(i) = UserLocale Then UserIndex = i + Next i + End If + +End Sub ' ScriptForge.SF_Region._LoadAllLocales + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvLocale As Variant) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property +''' pvLocale: a locale in the form language-COUNTRY (la-CO) or language only, or country only +''' When language or country only, any locale matching either the language or the country is selected + +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim vCurrencies As Variant ' Array of com.sun.star.i18n.Currency +Dim oCurrency As Object ' com.sun.star.i18n.Currency +Dim oLanguageCountryInfo As Object ' com.sun.star.i18n.LanguageCountryInfo +Dim oLocaleDataItem2 As Object ' com.sun.star.i18n.LocaleDataItem2 +Dim oCalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Dim oCalItem As Object ' com.sun.star.i18n.CalendarItem2 +Dim vCalItems() As Variant ' Array of days/months +Dim i As Integer, j As Integer + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "Region.Get" & psProperty + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Check: + If IsMissing(pvLocale) Or IsEmpty(pvLocale) Then pvLocale = "" + If Not SF_Utils._Validate(pvLocale, "Locale", V_STRING) Then GoTo Finally + + Select Case psProperty + Case "Currency", "Country" + Set oLocale = SF_Region._GetLocale(pvLocale, pbCountry := True) ' Country only is admitted + Case "Language", "DayNames", "DayAbbrevNames", "DayNarrowNames" _ + , "MonthNames", "MonthAbbrevNames", "MonthNarrowNames" + Set oLocale = SF_Region._GetLocale(pvLocale, pbLanguage := True) ' Language only is admitted + Case Else + Set oLocale = SF_Region._GetLocale(pvLocale) + End Select + If IsNull(oLocale) Then GoTo Finally + +Try: + Select Case psProperty + Case "Country", "Language" + Set oLanguageCountryInfo = LocaleData.getLanguageCountryInfo(oLocale) + With oLanguageCountryInfo + If psProperty = "Country" Then _PropertyGet = .CountryDefaultName Else _PropertyGet = .LanguageDefaultName + End With + Case "Currency" + vCurrencies = LocaleData.getAllCurrencies(oLocale) + _PropertyGet = "" + For Each oCurrency In vCurrencies + If oCurrency.Default Then + _PropertyGet = oCurrency.BankSymbol + Exit For + End If + Next oCurrency + Case "DatePatterns" + _PropertyGet = LocaleData.getDateAcceptancePatterns(oLocale) + Case "DateSeparator", "DecimalPoint", "ListSeparator", "ThousandSeparator", "TimeSeparator" + Set oLocaleDataItem2 = LocaleData.getLocaleItem2(oLocale) + With oLocaleDataItem2 + Select Case psProperty + Case "DateSeparator" : _PropertyGet = .dateSeparator + Case "DecimalPoint" : _PropertyGet = .decimalSeparator + Case "ListSeparator" : _PropertyGet = .listSeparator + Case "ThousandSeparator" : _PropertyGet = .thousandSeparator + Case "TimeSeparator" : _PropertyGet = .timeSeparator + End Select + End With + Case "DayAbbrevNames", "DayNames", "DayNarrowNames" + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendar(oLocale) + vCalItems = Array() : ReDim vCalItems(0 To 6) + For i = 0 To UBound(.Days2) + Set oCalItem = .Days2(i) + j = Iif(i = 0, 6, i - 1) + Select Case psProperty + Case "DayNames" : vCalItems(j) = oCalItem.FullName + Case "DayAbbrevNames" : vCalItems(j) = oCalItem.AbbrevName + Case "DayNarrowNames" : vCalItems(j) = oCalItem.NarrowName + End Select + Next i + _PropertyGet = vCalItems + End With + Case "MonthAbbrevNames", "MonthNames", "MonthNarrowNames" + Set oCalendarImpl = SF_Utils._GetUNOService("CalendarImpl") + With oCalendarImpl + .loadDefaultCalendar(oLocale) + vCalItems = Array() : ReDim vCalItems(0 To 11) + For i = 0 To UBound(.Months2) + Set oCalItem = .Months2(i) + Select Case psProperty + Case "MonthNames" : vCalItems(i) = oCalItem.FullName + Case "MonthAbbrevNames" : vCalItems(i) = oCalItem.AbbrevName + Case "MonthNarrowNames" : vCalItems(i) = oCalItem.NarrowName + End Select + Next i + _PropertyGet = vCalItems + End With + Case Else + _PropertyGet = "" + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Region._PropertyGet + +REM ================================================ END OF SCRIPTFORGE.SF_REGION + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Root.xba b/wizards/source/scriptforge/SF_Root.xba new file mode 100644 index 000000000..4db0efb42 --- /dev/null +++ b/wizards/source/scriptforge/SF_Root.xba @@ -0,0 +1,1070 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule +Option Private Module + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Root +''' ======= +''' FOR INTERNAL USE ONLY +''' Singleton class holding all persistent variables shared +''' by all the modules of the ScriptForge library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ============================================================= PRIVATE MEMBERS + +' Internals +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "ROOT" +Private MainFunction As String ' Name of method or property called by user script +Private MainFunctionArgs As String ' Syntax of method called by user script +Private StackLevel As Integer ' Depth of calls between internal methods + +' Error management +Private ErrorHandler As Boolean ' True = error handling active, False = internal debugging +Private ConsoleLines() As Variant ' Array of messages displayable in console +Private ConsoleDialog As Object ' SFDialogs.Dialog object +Private ConsoleControl As Object ' SFDialogs.DialogControl object +Private DisplayEnabled As Boolean ' When True, display of console or error messages is allowed +Private StopWhenError As Boolean ' When True, process stops after error > "WARNING" +Private TriggeredByPython As Boolean ' When True, the actual user script is a Python script +Private DebugMode As Boolean ' When True, log enter/exit each official Sub + +' Progress and status bars +Private ProgressBarDialog As Object ' SFDialogs.Dialog object +Private ProgressBarText As Object ' SFDialogs.DialogControl object +Private ProgressBarBar As Object ' SFDialogs.DialogControl object +Private Statusbar As Object + +' Services management +Private ServicesList As Variant ' Dictionary of provided services + +' Usual UNO services +Private FunctionAccess As Object ' com.sun.star.sheet.FunctionAccess +Private PathSettings As Object ' com.sun.star.util.PathSettings +Private PathSubstitution As Object ' com.sun.star.util.PathSubstitution +Private ScriptProvider As Object ' com.sun.star.script.provider.MasterScriptProviderFactory +Private SystemShellExecute As Object ' com.sun.star.system.SystemShellExecute +Private CoreReflection As Object ' com.sun.star.reflection.CoreReflection +Private DispatchHelper As Object ' com.sun.star.frame.DispatchHelper +Private TextSearch As Object ' com.sun.star.util.TextSearch +Private SearchOptions As Object ' com.sun.star.util.SearchOptions +Private SystemLocale As Object ' com.sun.star.lang.Locale +Private OfficeLocale As Object ' com.sun.star.lang.Locale +Private FormatLocale As Object ' com.sun.star.lang.Locale +Private LocaleData As Object ' com.sun.star.i18n.LocaleData +Private CalendarImpl As Object ' com.sun.star.i18n.CalendarImpl +Private Number2Text As Object ' com.sun.star.linguistic2.NumberText +Private PrinterServer As Object ' com.sun.star.awt.PrinterServer +Private CharacterClass As Object ' com.sun.star.i18n.CharacterClassification +Private FileAccess As Object ' com.sun.star.ucb.SimpleFileAccess +Private FilterFactory As Object ' com.sun.star.document.FilterFactory +Private FolderPicker As Object ' com.sun.star.ui.dialogs.FolderPicker +Private FilePicker As Object ' com.sun.star.ui.dialogs.FilePicker +Private URLTransformer As Object ' com.sun.star.util.URLTransformer +Private Introspection As Object ' com.sun.star.beans.Introspection +Private BrowseNodeFactory As Object ' com.sun.star.script.browse.BrowseNodeFactory +Private DatabaseContext As Object ' com.sun.star.sdb.DatabaseContext +Private ConfigurationProvider _ + As Object ' com.sun.star.configuration.ConfigurationProvider +Private PackageProvider As Object ' com.sun.star.comp.deployment.PackageInformationProvider +Private MailService As Object ' com.sun.star.system.SimpleCommandMail or com.sun.star.system.SimpleSystemMail +Private GraphicExportFilter As Object ' com.sun.star.drawing.GraphicExportFilter +Private Toolkit As Object ' com.sun.star.awt.Toolkit + +' Specific persistent services objects or properties +Private FileSystemNaming As String ' If "SYS", file and folder naming is based on operating system notation +Private PythonHelper As String ' File name of Python helper functions (stored in $(inst)/share/Scripts/python) +Private PythonHelper2 As String ' Alternate Python helper file name for test purposes +Private LocalizedInterface As Object ' ScriptForge own L10N service +Private OSName As String ' WIN, LINUX, MACOS +Private SFDialogs As Variant ' Persistent storage for the SFDialogs library +Private SFForms As Variant ' Persistent storage for the SF_Form class in the SFDocuments library +Private PythonStorage As Variant ' Persistent storage for the objects created and processed in Python +Private PythonPermanent As Long ' Number of permanent entries in PythonStorage containing standard module objects + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "ROOT" + MainFunction = "" + MainFunctionArgs = "" + StackLevel = 0 + ErrorHandler = True + ConsoleLines = Array() + Set ConsoleDialog = Nothing + Set ConsoleControl = Nothing + DisplayEnabled = True + StopWhenError = True + TriggeredByPython = False + DebugMode = False + Set ProgressBarDialog = Nothing + Set ProgressBarText = Nothing + Set progressBarBar = Nothing + Set Statusbar = Nothing + ServicesList = Empty + Set FunctionAccess = Nothing + Set PathSettings = Nothing + Set PathSubstitution = Nothing + Set ScriptProvider = Nothing + Set SystemShellExecute = Nothing + Set CoreReflection = Nothing + Set DispatchHelper = Nothing + Set TextSearch = Nothing + Set SearchOptions = Nothing + Set SystemLocale = Nothing + Set OfficeLocale = Nothing + Set FormatLocale = Nothing + Set LocaleData = Nothing + Set CalendarImpl = Nothing + Set Number2Text = Nothing + Set PrinterServer = Nothing + Set CharacterClass = Nothing + Set FileAccess = Nothing + Set FilterFactory = Nothing + Set FolderPicker = Nothing + Set FilePicker = Nothing + Set URLTransformer = Nothing + Set Introspection = Nothing + FileSystemNaming = "ANY" + PythonHelper = "ScriptForgeHelper.py" + PythonHelper2 = "" + Set LocalizedInterface = Nothing + Set BrowseNodeFactory = Nothing + Set DatabaseContext = Nothing + Set ConfigurationProvider = Nothing + Set PackageProvider = Nothing + Set MailService = Nothing + Set GraphicExportFilter = Nothing + Set Toolkit = Nothing + OSName = "" + SFDialogs = Empty + SFForms = Empty + PythonStorage = Empty + PythonPermanent = -1 +End Sub ' ScriptForge.SF_Root Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' ScriptForge.SF_Root Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' ScriptForge.SF_Root Explicit destructor + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Sub _AddToConsole(ByVal psLine As String) +''' Add a new line to the console +''' TAB characters are expanded before the insertion of the line +''' NB: Array redimensioning of a member of an object must be done in the class module +''' Args: +''' psLine: the line to add + +Dim lConsole As Long ' UBound of ConsoleLines +Dim sLine As String ' Alias of psLine + + ' Resize ConsoleLines + lConsole = UBound(ConsoleLines) + If lConsole < 0 Then + ReDim ConsoleLines(0) + Else + ReDim Preserve ConsoleLines(0 To lConsole + 1) + End If + + ' Add a timestamp to the line and insert it (without date) + sLine = Mid(SF_Utils._Repr(Now()), 12) & " -> " & psLine + ConsoleLines(lConsole + 1) = sLine + + ' Add the new line to the actual (probably non-modal) console, if active + If Not IsNull(ConsoleDialog) Then + If ConsoleDialog._IsStillAlive(False) Then ' False to not raise an error + If IsNull(ConsoleControl) Then Set ConsoleControl = ConsoleDialog.Controls(SF_Exception.CONSOLENAME) ' Should not happen ... + ConsoleControl.WriteLine(sLine) + End If + End If + +End Sub ' ScriptForge.SF_Root._AddToConsole + +REM ----------------------------------------------------------------------------- +Public Function _AddToPythonStorage(ByRef poObject As Object) As Long +''' Insert a newly created object in the Python persistent storage +''' and return the index of the used entry +''' The persistent storage is a simple array of objects +''' Args: +''' poObject: the object to insert + +Dim lIndex As Long ' Return value +Dim lSize As Long ' UBound of the persistent storage +Dim i As Long + +Check: + lIndex = -1 + If IsNull(poObject) Then Exit Function + On Local Error GoTo Finally + lSize = UBound(PythonStorage) + +Try: + ' Can an empty entry be reused ? + For i = PythonPermanent + 1 To lSize + If IsNull(PythonStorage(i)) Then + lIndex = i + Exit For + End If + Next i + + ' Resize Python storage if no empty space + If lIndex < 0 Then + lSize = lSize + 1 + ReDim Preserve PythonStorage(0 To lSize) + lIndex = lSize + End If + + ' Insert new object + Set PythonStorage(lIndex) = poObject + +Finally: + _AddToPythonStorage = lIndex + Exit Function +End Function ' ScriptForge.SF_Root._AddToPythonStorage + +REM ------------------------------------------------------------------------------ +Public Function _GetLocalizedInterface() As Object +''' Returns the LN object instance related to the ScriptForge internal localization +''' If not yet done, load it from the shipped po files +''' Makes that the localized user interface is loaded only when needed + +Try: + If IsNull(LocalizedInterface) Then _LoadLocalizedInterface() + +Finally: + Set _GetLocalizedInterface = LocalizedInterface + Exit Function +End Function ' ScriptForge.SF_Root._GetLocalizedInterface + +REM ----------------------------------------------------------------------------- +Public Sub _InitPythonStorage() +''' Make PythonStorage an array +''' In prevision to an abundant use of those objects in Python, hardcode to optimize the performance and memory : +''' Initialize the first entries with the standard module objects located in the ScriptForge library + +Try: + If Not IsArray(PythonStorage) Then + PythonPermanent = 8 + PythonStorage = Array() + ReDim PythonStorage(0 To PythonPermanent) + ' Initialize each entry + PythonStorage(0) = ScriptForge.SF_Array + PythonStorage(1) = ScriptForge.SF_Exception + PythonStorage(2) = ScriptForge.SF_FileSystem + PythonStorage(3) = ScriptForge.SF_Platform + PythonStorage(4) = ScriptForge.SF_Region + PythonStorage(5) = ScriptForge.SF_Services + PythonStorage(6) = ScriptForge.SF_Session + PythonStorage(7) = ScriptForge.SF_String + PythonStorage(8) = ScriptForge.SF_UI + End If + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_Root._InitPythonStorage + +REM ----------------------------------------------------------------------------- +Public Sub _LoadLocalizedInterface(Optional ByVal psMode As String) +''' Build the user interface in a persistent L10N object +''' Executed - only once - at first request of a label inside the LocalizedInterface dictionary +''' Args: +''' psMode: ADDTEXT => the (english) labels are loaded from code below +''' POFILE => the localized labels are loaded from a PO file +''' the name of the file is "la.po" where la = language part of locale +''' (fallback to ADDTEXT mode if file does not exist) + +Dim sInstallFolder As String ' ScriptForge installation directory +Dim sPOFolder As String ' Folder containing the PO files +Dim sPOFile As String ' PO File to load +Dim sLocale As String ' Locale + + If ErrorHandler Then On Local Error GoTo Catch + +Try: + 'TODO: Modify default value + If IsMissing(psMode) Then psMode = "POFILE" + + If psMode = "POFILE" Then ' Use this mode in production + ' Build the po file name + With SF_FileSystem + sInstallFolder = ._SFInstallFolder() ' ScriptForge installation folder + sLocale = SF_Utils._GetUNOService("OfficeLocale").Language + sPOFolder = .BuildPath(sInstallFolder, "po") + sPOFile = .BuildPath(sPOFolder, sLocale & ".po") + If sLocale = "en" Then ' LocalizedInterface loaded by code i.o. read from po file + psMode = "ADDTEXT" + ElseIf Not .FileExists(sPOFile) Then ' File not found => load texts from code below + psMode = "ADDTEXT" + Else + Set LocalizedInterface = CreateScriptService("L10N", sPOFolder, sLocale) + End If + End With + End If + + If psMode = "ADDTEXT" Then ' Use this mode in development to prepare a new POT file + Set LocalizedInterface = CreateScriptService("L10N") + With LocalizedInterface + ' SF_Exception.Raise + .AddText( Context := "ERRORNUMBER" _ + , MsgId := "Error %1" _ + , Comment := "Title in error message box\n" _ + & "%1: an error number" _ + ) + .AddText( Context := "ERRORLOCATION" _ + , MsgId := "Location : %1" _ + , Comment := "Error message box\n" _ + & "%1: a line number" _ + ) + .AddText( Context := "LONGERRORDESC" _ + , MsgId := "Error %1 - Location = %2 - Description = %3" _ + , Comment := "Logfile record" _ + ) + .AddText( Context := "STOPEXECUTION" _ + , MsgId := "THE EXECUTION IS CANCELLED." _ + , Comment := "Any blocking error message" _ + ) + .AddText( Context := "NEEDMOREHELP" _ + , MsgId := "Do you want to receive more information about the '%1' method ?" _ + , Comment := "Any blocking error message\n" _ + & "%1: a method name" _ + ) + ' SF_Exception.RaiseAbort + .AddText( Context := "INTERNALERROR" _ + , MsgId := "The ScriptForge library has crashed. The reason is unknown.\n" _ + & "Maybe a bug that could be reported on\n" _ + & "\thttps://bugs.documentfoundation.org/\n\n" _ + & "More details : \n\n" _ + , Comment := "SF_Exception.RaiseAbort error message" _ + ) + ' SF_Utils._Validate + .AddText( Context := "VALIDATESOURCE" _ + , MsgId := "Library : \t%1\nService : \t%2\nMethod : \t%3" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: probably ScriptForge\n" _ + & "%2: service or module name\n" _ + & "%3: property or method name where the error occurred" _ + ) + .AddText( Context := "VALIDATEARGS" _ + , MsgId := "Arguments: %1" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: list of arguments of the method" _ + ) + .AddText( Context := "VALIDATEERROR" _ + , MsgId := "A serious error has been detected in your code on argument : « %1 »." _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name" _ + ) + .AddText( Context := "VALIDATIONRULES" _ + , MsgId := "\tValidation rules :", Comment := "SF_Utils.Validate error message" _ + ) + .AddText( Context := "VALIDATETYPES" _ + , MsgId := "\t\t« %1 » must have next type (or one of next types) : %2" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: Comma separated list of allowed types" _ + ) + .AddText( Context := "VALIDATEVALUES" _ + , MsgId := "\t\t« %1 » must contain one of next values : %2" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: Comma separated list of allowed values" _ + ) + .AddText( Context := "VALIDATEREGEX" _ + , MsgId := "\t\t« %1 » must match next regular expression : %2" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: A regular expression" _ + ) + .AddText( Context := "VALIDATECLASS" _ + , MsgId := "\t\t« %1 » must be a Basic object of class : %2" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: The name of a Basic class" _ + ) + .AddText( Context := "VALIDATEACTUAL" _ + , MsgId := "The actual value of « %1 » is : '%2'" _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: The value of the argument as a string" _ + ) + .AddText( Context := "VALIDATEMISSING" _ + , MsgId := "The « %1 » argument is mandatory, yet it is missing." _ + , Comment := "SF_Utils._Validate error message\n" _ + & "%1: Wrong argument name" _ + ) + ' SF_Utils._ValidateArray + .AddText( Context := "VALIDATEARRAY" _ + , MsgId := "\t\t« %1 » must be an array." _ + , Comment := "SF_Utils._ValidateArray error message\n" _ + & "%1: Wrong argument name" _ + ) + .AddText( Context := "VALIDATEDIMS" _ + , MsgId := "\t\t« %1 » must have exactly %2 dimension(s)." _ + , Comment := "SF_Utils._ValidateArray error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: Number of dimensions of the array" _ + ) + .AddText( Context := "VALIDATEALLTYPES" _ + , MsgId := "\t\t« %1 » must have all elements of the same type : %2" _ + , Comment := "SF_Utils._ValidateArray error message\n" _ + & "%1: Wrong argument name\n" _ + & "%2: Either one single type or 'String, Date, Numeric'" _ + ) + .AddText( Context := "VALIDATENOTNULL" _ + , MsgId := "\t\t« %1 » must not contain any NULL or EMPTY elements." _ + , Comment := "SF_Utils._ValidateArray error message\n" _ + & "%1: Wrong argument name\n" _ + & "NULL and EMPTY should not be translated" _ + ) + ' SF_Utils._ValidateFile + .AddText( Context := "VALIDATEFILE" _ + , MsgId := "\t\t« %1 » must be of type String." _ + , Comment := "SF_Utils._ValidateFile error message\n" _ + & "%1: Wrong argument name\n" _ + & "'String' should not be translated" _ + ) + .AddText( Context := "VALIDATEFILESYS" _ + , MsgId := "\t\t« %1 » must be a valid file or folder name expressed in the operating system native notation." _ + , Comment := "SF_Utils._ValidateFile error message\n" _ + & "%1: Wrong argument name" _ + ) + .AddText( Context := "VALIDATEFILEURL" _ + , MsgId := "\t\t« %1 » must be a valid file or folder name expressed in the portable URL notation." _ + , Comment := "SF_Utils._ValidateFile error message\n" _ + & "%1: Wrong argument name\n" _ + & "'URL' should not be translated" _ + ) + .AddText( Context := "VALIDATEFILEANY" _ + , MsgId := "\t\t« %1 » must be a valid file or folder name." _ + , Comment := "SF_Utils._ValidateFile error message\n" _ + & "%1: Wrong argument name" _ + ) + .AddText( Context := "VALIDATEWILDCARD" _ + , MsgId := "\t\t« %1 » may contain one or more wildcard characters (?, *) in its last path component only." _ + , Comment := "SF_Utils._ValidateFile error message\n" _ + & "%1: Wrong argument name\n" _ + & "'(?, *)' is to be left as is" _ + ) + ' SF_Array.RangeInit + .AddText( Context := "ARRAYSEQUENCE" _ + , MsgId := "The respective values of 'From', 'UpTo' and 'ByStep' are incoherent.\n\n" _ + & "\t« From » = %1\n" _ + & "\t« UpTo » = %2\n" _ + & "\t« ByStep » = %3" _ + , Comment := "SF_Array.RangeInit error message\n" _ + & "%1, %2, %3: Numeric values\n" _ + & "'From', 'UpTo', 'ByStep' should not be translated" _ + ) + ' SF_Array.AppendColumn, AppendRow, PrependColumn, PrependRow + .AddText( Context := "ARRAYINSERT" _ + , MsgId := "The array and the vector to insert have incompatible sizes.\n\n" _ + & "\t« Array_2D » = %2\n" _ + & "\t« %1 » = %3" _ + , Comment := "SF_Array.AppendColumn (...) error message\n" _ + & "%1: 'Column' or 'Row' of a matrix\n" _ + & "%2, %3: array contents\n" _ + & "'Array_2D' should not be translated" _ + ) + ' SF_Array.ExtractColumn, ExtractRow + .AddText( Context := "ARRAYINDEX1" _ + , MsgId := "The given index does not fit within the bounds of the array.\n\n" _ + & "\t« Array_2D » = %2\n" _ + & "\t« %1 » = %3" _ + , Comment := "SF_Array.ExtractColumn (...) error message\n" _ + & "%1: 'Column' or 'Row' of a matrix\n" _ + & "%2, %3: array contents\n" _ + & "'Array_2D' should not be translated" _ + ) + ' SF_Array.ExtractColumn, ExtractRow + .AddText( Context := "ARRAYINDEX2" _ + , MsgId := "The given slice limits do not fit within the bounds of the array.\n\n" _ + & "\t« Array_1D » = %1\n" _ + & "\t« From » = %2\n" _ + & "\t« UpTo » = %3" _ + , Comment := "SF_Array.ExtractColumn (...) error message\n" _ + & "%1: 'Column' or 'Row' of a matrix\n" _ + & "%2, %3: array contents\n" _ + & "'Array_1D', 'From' and 'UpTo' should not be translated" _ + ) + ' SF_Array.ImportFromCSVFile + .AddText( Context := "CSVPARSING" _ + , MsgId := "The given file could not be parsed as a valid CSV file.\n\n" _ + & "\t« File name » = %1\n" _ + & "\tLine number = %2\n" _ + & "\tContent = %3" _ + , Comment := "SF_Array.ImportFromCSVFile error message\n" _ + & "%1: a file name\n" _ + & "%2: numeric\n" _ + & "%3: a long string" _ + ) + ' SF_Dictionary.Add/ReplaceKey + .AddText( Context := "DUPLICATEKEY" _ + , MsgId := "The insertion of a new key " _ + & "into a dictionary failed because the key already exists.\n" _ + & "Note that the comparison between keys is NOT case-sensitive.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_Dictionary Add/ReplaceKey error message\n" _ + & "%1: An identifier" _ + & "%2: a (potentially long) string" _ + ) + ' SF_Dictionary.Remove/ReplaceKey/ReplaceItem + .AddText( Context := "UNKNOWNKEY" _ + , MsgId := "The requested key does not exist in the dictionary.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_Dictionary Remove/ReplaceKey/ReplaceItem error message\n" _ + & "%1: An identifier" _ + & "%2: a (potentially long) string" _ + ) + ' SF_Dictionary.Add/ReplaceKey + .AddText( Context := "INVALIDKEY" _ + , MsgId := "The insertion or the update of an entry " _ + & "into a dictionary failed because the given key contains only spaces." _ + , Comment := "SF_Dictionary Add/ReplaceKey error message\n" _ + ) + ' SF_FileSystem.CopyFile/MoveFile/DeleteFile/CreateScriptService("L10N") + .AddText( Context := "UNKNOWNFILE" _ + , MsgId := "The given file could not be found on your system.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/delete error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name" _ + ) + ' SF_FileSystem.CopyFolder/MoveFolder/DeleteFolder/Files/SubFolders + .AddText( Context := "UNKNOWNFOLDER" _ + , MsgId := "The given folder could not be found on your system.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/delete error message\n" _ + & "%1: An identifier\n" _ + & "%2: A folder name" _ + ) + ' SF_FileSystem.CopyFile/MoveFolder/DeleteFile + .AddText( Context := "NOTAFILE" _ + , MsgId := "« %1 » contains the name of an existing folder, not that of a file.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/delete error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name" _ + ) + ' SF_FileSystem.CopyFolder/MoveFolder/DeleteFolder/Files/SubFolders + .AddText( Context := "NOTAFOLDER" _ + , MsgId := "« %1 » contains the name of an existing file, not that of a folder.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/delete error message\n" _ + & "%1: An identifier\n" _ + & "%2: A folder name" _ + ) + ' SF_FileSystem.Copy+Move/File+Folder/CreateTextFile/OpenTextFile + .AddText( Context := "OVERWRITE" _ + , MsgId := "You tried to create a new file which already exists. Overwriting it has been rejected.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/... error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name" _ + ) + ' SF_FileSystem.Copy+Move+Delete/File+Folder + .AddText( Context := "READONLY" _ + , MsgId := "Copying or moving a file to a destination which has its read-only attribute set, or deleting such a file or folder is forbidden.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/delete error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name" _ + ) + ' SF_FileSystem.Copy+Move+Delete/File+Folder + .AddText( Context := "NOFILEMATCH" _ + , MsgId := "When « %1 » contains wildcards. at least one file or folder must match the given filter. Otherwise the operation is rejected.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem copy/move/delete error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file or folder name with wildcards" _ + ) + ' SF_FileSystem.CreateFolder + .AddText( Context := "FOLDERCREATION" _ + , MsgId := "« %1 » contains the name of an existing file or an existing folder. The operation is rejected.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_FileSystem CreateFolder error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file or folder name" _ + ) + ' SF_Services.CreateScriptService + .AddText( Context := "UNKNOWNSERVICE" _ + , MsgId := "No service named '%4' has been registered for the library '%3'.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_Services.CreateScriptService error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: A Basic library name\n" _ + & "%4: A service (1 word) name" _ + ) + ' SF_Services.CreateScriptService + .AddText( Context := "SERVICESNOTLOADED" _ + , MsgId := "The library '%3' and its services could not been loaded.\n" _ + & "The reason is unknown.\n" _ + & "However, checking the '%3.SF_Services.RegisterScriptServices()' function and its return value can be a good starting point.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_Services.CreateScriptService error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: A Basic library name" _ + ) + ' SF_Session.ExecuteCalcFunction + .AddText( Context := "CALCFUNC" _ + , MsgId := "The Calc '%1' function encountered an error. Either the given function does not exist or its arguments are invalid." _ + , Comment := "SF_Session.ExecuteCalcFunction error message\n" _ + & "'Calc' should not be translated" _ + ) + ' SF_Session._GetScript + .AddText( Context := "NOSCRIPT" _ + , MsgId := "The requested %1 script could not be located in the given libraries and modules.\n" _ + & "« %2 » = %3\n" _ + & "« %4 » = %5" _ + , Comment := "SF_Session._GetScript error message\n" _ + & "%1: 'Basic' or 'Python'\n" _ + & "%2: An identifier\n" _ + & "%3: A string\n" _ + & "%4: An identifier\n" _ + & "%5: A string" _ + ) + ' SF_Session.ExecuteBasicScript + .AddText( Context := "SCRIPTEXEC" _ + , MsgId := "An exception occurred during the execution of the Basic script.\n" _ + & "Cause: %3\n" _ + & "« %1 » = %2" _ + , Comment := "SF_Session.ExecuteBasicScript error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: A (long) string" _ + ) + ' SF_Session.SendMail + .AddText( Context := "WRONGEMAIL" _ + , MsgId := "One of the email addresses has been found invalid.\n" _ + & "Invalid mail = « %1 »" _ + , Comment := "SF_Session.SendMail error message\n" _ + & "%1 = a mail address" _ + ) + ' SF_Session.SendMail + .AddText( Context := "SENDMAIL" _ + , MsgId := "The message could not be sent due to a system error.\n" _ + & "A possible cause is that LibreOffice could not find any mail client." _ + , Comment := "SF_Session.SendMail error message" _ + ) + ' SF_TextStream._IsFileOpen + .AddText( Context := "FILENOTOPEN" _ + , MsgId := "The requested file operation could not be executed because the file was closed previously.\n\n" _ + & "File name = '%1'" _ + , Comment := "SF_TextStream._IsFileOpen error message\n" _ + & "%1: A file name" _ + ) + ' SF_TextStream._IsFileOpen + .AddText( Context := "FILEOPENMODE" _ + , MsgId := "The requested file operation could not be executed because it is incompatible with the mode in which the file was opened.\n\n" _ + & "File name = '%1'\n" _ + & "Open mode = %2" _ + , Comment := "SF_TextStream._IsFileOpen error message\n" _ + & "%1: A file name\n" _ + & "%2: READ, WRITE or APPEND" _ + ) + ' SF_TextStream.ReadLine, ReadAll, SkipLine + .AddText( Context := "ENDOFFILE" _ + , MsgId := "The requested file read operation could not be completed because an unexpected end-of-file was encountered.\n\n" _ + & "File name = '%1'" _ + , Comment := "SF_TextStream.ReadLine/ReadAll/SkipLine error message\n" _ + & "%1: A file name" _ + ) + ' SF_UI.Document + .AddText( Context := "DOCUMENT" _ + , MsgId := "The requested document could not be found.\n\n" _ + & "%1 = '%2'" _ + , Comment := "SF_UI.GetDocument error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string" _ + ) + ' SF_UI.Create + .AddText( Context := "DOCUMENTCREATION" _ + , MsgId := "The creation of a new document failed.\n" _ + & "Something must be wrong with some arguments.\n\n" _ + & "Either the document type is unknown, or no template file was given,\n" _ + & "or the given template file was not found on your system.\n\n" _ + & "%1 = '%2'\n" _ + & "%3 = '%4'" _ + , Comment := "SF_UI.GetDocument error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A string" _ + ) + ' SF_UI.OpenDocument + .AddText( Context := "DOCUMENTOPEN" _ + , MsgId := "The opening of the document failed.\n" _ + & "Something must be wrong with some arguments.\n\n" _ + & "Either the file does not exist, or the password is wrong, or the given filter is invalid.\n\n" _ + & "%1 = '%2'\n" _ + & "%3 = '%4'\n" _ + & "%5 = '%6'" _ + , Comment := "SF_UI.OpenDocument error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A string\n" _ + & "%5: An identifier\n" _ + & "%6: A string" _ + ) + ' SF_UI.OpenBaseDocument + .AddText( Context := "BASEDOCUMENTOPEN" _ + , MsgId := "The opening of the Base document failed.\n" _ + & "Something must be wrong with some arguments.\n\n" _ + & "Either the file does not exist, or the file is not registered under the given name.\n\n" _ + & "%1 = '%2'\n" _ + & "%3 = '%4'" _ + , Comment := "SF_UI.OpenDocument error message\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A string" _ + ) + ' SF_Document._IsStillAlive + .AddText( Context := "DOCUMENTDEAD" _ + , MsgId := "The requested action could not be executed because the document was closed inadvertently.\n\n" _ + & "The concerned document is '%1'" _ + , Comment := "SF_Document._IsStillAlive error message\n" _ + & "%1: A file name" _ + ) + ' SF_Document.Save + .AddText( Context := "DOCUMENTSAVE" _ + , MsgId := "The document could not be saved.\n" _ + & "Either the document has been opened read-only, or the destination file has a read-only attribute set, " _ + & "or the file where to save to is undefined.\n\n" _ + & "%1 = '%2'" _ + , Comment := "SF_Document.SaveAs error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name\n" _ + ) + ' SF_Document.SaveAs + .AddText( Context := "DOCUMENTSAVEAS" _ + , MsgId := "The document could not be saved.\n" _ + & "Either the document must not be overwritten, or the destination file has a read-only attribute set, " _ + & "or the given filter is invalid.\n\n" _ + & "%1 = '%2'\n" _ + & "%3 = %4\n" _ + & "%5 = '%6'" _ + , Comment := "SF_Document.SaveAs error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name\n" _ + & "%3: An identifier\n" _ + & "%4: True or False\n" _ + & "%5: An identifier\n" _ + & "%6: A string" _ + ) + ' SF_Document.any update + .AddText( Context := "DOCUMENTREADONLY" _ + , MsgId := "You tried to edit a document which is not modifiable. The document has not been changed.\n\n" _ + & "« %1 » = %2" _ + , Comment := "SF_Document any update\n" _ + & "%1: An identifier\n" _ + & "%2: A file name" _ + ) + ' SF_Base.GetDatabase + .AddText( Context := "DBCONNECT" _ + , MsgId := "The database related to the actual Base document could not be retrieved.\n" _ + & "Check the connection/login parameters.\n\n" _ + & "« %1 » = '%2'\n" _ + & "« %3 » = '%4'\n" _ + & "« Document » = %5" _ + , Comment := "SF_Base GetDatabase\n" _ + & "%1: An identifier\n" _ + & "%2: A user name\n" _ + & "%3: An identifier\n" _ + & "%4: A password\n" _ + & "%5: A file name" _ + ) + ' SF_Calc._ParseAddress (sheet) + .AddText( Context := "CALCADDRESS1" _ + , MsgId := "The given address does not correspond with a valid sheet name.\n\n" _ + & "« %1 » = %2\n" _ + & "« %3 » = %4" _ + , Comment := "SF_Calc _ParseAddress (sheet)\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A file name" _ + ) + ' SF_Calc._ParseAddress (range) + .AddText( Context := "CALCADDRESS2" _ + , MsgId := "The given address does not correspond with a valid range of cells.\n\n" _ + & "« %1 » = %2\n" _ + & "« %3 » = %4" _ + , Comment := "SF_Calc _ParseAddress (range)\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A file name" _ + ) + ' SF_Calc.InsertSheet + .AddText( Context := "DUPLICATESHEET" _ + , MsgId := "There exists already in the document a sheet with the same name.\n\n" _ + & "« %1 » = %2\n" _ + & "« %3 » = %4" _ + , Comment := "SF_Calc InsertSheet\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A file name" _ + ) + ' SF_Calc.Offset + .AddText( Context := "OFFSETADDRESS" _ + , MsgId := "The computed range falls beyond the sheet boundaries or is meaningless.\n\n" _ + & "« %1 » = %2\n" _ + & "« %3 » = %4\n" _ + & "« %5 » = %6\n" _ + & "« %7 » = %8\n" _ + & "« %9 » = %10\n" _ + & "« %11 » = %12" _ + , Comment := "SF_Calc Offset\n" _ + & "%1: An identifier\n" _ + & "%2: A Calc reference\n" _ + & "%3: An identifier\n" _ + & "%4: A number\n" _ + & "%5: An identifier\n" _ + & "%6: A number\n" _ + & "%7: An identifier\n" _ + & "%8: A number\n" _ + & "%9: An identifier\n" _ + & "%10: A number\n" _ + & "%11: An identifier\n" _ + & "%12: A file name" _ + ) + ' SF_Calc.CreateChart + .AddText( Context := "DUPLICATECHART" _ + , MsgId := "A chart with the same name exists already in the sheet.\n\n" _ + & "« %1 » = %2\n" _ + & "« %3 » = %4\n" _ + & "« %5 » = %6\n" _ + , Comment := "SF_Calc CreateChart\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A string\n" _ + & "%5: An identifier\n" _ + & "%6: A file name" _ + ) + ' SF_Calc.ExportRangeToFile + .AddText( Context := "RANGEEXPORT" _ + , MsgId := "The given range could not be exported.\n" _ + & "Either the destination file must not be overwritten, or it has a read-only attribute set.\n\n" _ + & "%1 = '%2'\n" _ + & "%3 = %4" _ + , Comment := "SF_Calc.ExportRangeToFile error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name\n" _ + & "%3: An identifier\n" _ + & "%4: True or False\n" _ + ) + ' SF_Chart.ExportToFile + .AddText( Context := "CHARTEXPORT" _ + , MsgId := "The chart could not be exported.\n" _ + & "Either the destination file must not be overwritten, or it has a read-only attribute set.\n\n" _ + & "%1 = '%2'\n" _ + & "%3 = %4" _ + , Comment := "SF_Chart.ExportToFile error message\n" _ + & "%1: An identifier\n" _ + & "%2: A file name\n" _ + & "%3: An identifier\n" _ + & "%4: True or False\n" _ + ) + ' SF_Form._IsStillAlive + .AddText( Context := "FORMDEAD" _ + , MsgId := "The requested action could not be executed because the form is not open or the document was closed inadvertently.\n\n" _ + & "The concerned form is '%1' in document '%2'." _ + , Comment := "SF_Dialog._IsStillAlive error message\n" _ + & "%1: An identifier" _ + & "%2: A file name" _ + ) + ' SF_Calc.Forms + .AddText( Context := "CALCFORMNOTFOUND" _ + , MsgId := "The requested form could not be found in the Calc sheet. The given index is off-limits.\n\n" _ + & "The concerned Calc document is '%3'.\n\n" _ + & "The name of the sheet = '%2'\n" _ + & "The index = %1." _ + , Comment := "SF_Form determination\n" _ + & "%1: A number\n" _ + & "%2: A sheet name\n" _ + & "%3: A file name" _ + ) + ' SF_Document.Forms + .AddText( Context := "WRITERFORMNOTFOUND" _ + , MsgId := "The requested form could not be found in the Writer document. The given index is off-limits.\n\n" _ + & "The concerned Writer document is '%2'.\n\n" _ + & "The index = %1." _ + , Comment := "SF_Form determination\n" _ + & "%1: A number\n" _ + & "%2: A file name" _ + ) + ' SF_Base.Forms + .AddText( Context := "BASEFORMNOTFOUND" _ + , MsgId := "The requested form could not be found in the form document '%2'. The given index is off-limits.\n\n" _ + & "The concerned Base document is '%3'.\n\n" _ + & "The index = %1." _ + , Comment := "SF_Form determination\n" _ + & "%1: A number\n" _ + & "%2: A string\n" _ + & "%3: A file name" _ + ) + ' SF_Form.Subforms + .AddText( Context := "SUBFORMNOTFOUND" _ + , MsgId := "The requested subform could not be found below the given main form.\n\n" _ + & "The main form = '%2'.\n" _ + & "The subform = '%1'." _ + , Comment := "SF_Form determination\n" _ + & "%1: A form name\n" _ + & "%2: A form name" _ + ) + ' SF_FormControl._SetProperty + .AddText( Context := "FORMCONTROLTYPE" _ + , MsgId := "The control '%1' in form '%2' is of type '%3'.\n" _ + & "The property or method '%4' is not applicable on that type of form controls." _ + , Comment := "SF_FormControl property setting\n" _ + & "%1: An identifier\n" _ + & "%2: An identifier\n" _ + & "%3: A string\n" _ + & "%4: An identifier" _ + ) + ' SF_Dialog._NewDialog + .AddText( Context := "DIALOGNOTFOUND" _ + , MsgId := "The requested dialog could not be located in the given container or library.\n" _ + & "« %1 » = %2\n" _ + & "« %3 » = %4\n" _ + & "« %5 » = %6\n" _ + & "« %7 » = %8" _ + , Comment := "SF_Dialog creation\n" _ + & "%1: An identifier\n" _ + & "%2: A string\n" _ + & "%3: An identifier\n" _ + & "%4: A file name\n" _ + & "%5: An identifier\n" _ + & "%6: A string\n" _ + & "%7: An identifier\n" _ + & "%8: A string" _ + ) + ' SF_Dialog._IsStillAlive + .AddText( Context := "DIALOGDEAD" _ + , MsgId := "The requested action could not be executed because the dialog was closed inadvertently.\n\n" _ + & "The concerned dialog is '%1'." _ + , Comment := "SF_Dialog._IsStillAlive error message\n" _ + & "%1: An identifier" _ + ) + ' SF_DialogControl._SetProperty + .AddText( Context := "CONTROLTYPE" _ + , MsgId := "The control '%1' in dialog '%2' is of type '%3'.\n" _ + & "The property or method '%4' is not applicable on that type of dialog controls." _ + , Comment := "SF_DialogControl property setting\n" _ + & "%1: An identifier\n" _ + & "%2: An identifier\n" _ + & "%3: A string\n" _ + & "%4: An identifier" _ + ) + ' SF_DialogControl.WriteLine + .AddText( Context := "TEXTFIELD" _ + , MsgId := "The control '%1' in dialog '%2' is not a multiline text field.\n" _ + & "The requested method could not be executed." _ + , Comment := "SF_DialogControl add line in textbox\n" _ + & "%1: An identifier\n" _ + & "%2: An identifier" _ + ) + ' SF_Database.RunSql + .AddText( Context := "DBREADONLY" _ + , MsgId := "The database has been opened in read-only mode.\n" _ + & "The '%1' method must not be executed in this context." _ + , Comment := "SF_Database when running update SQL statement\n" _ + & "%1: The concerned method" _ + ) + ' SF_Database._ExecuteSql + .AddText( Context := "SQLSYNTAX" _ + , MsgId := "An SQL statement could not be interpreted or executed by the database system.\n" _ + & "Check its syntax, table and/or field names, ...\n\n" _ + & "SQL Statement : « %1 »" _ + , Comment := "SF_Database can't interpret SQL statement\n" _ + & "%1: The statement" _ + ) + ' SF_Exception.PythonShell (Python only) + .AddText( Context := "PYTHONSHELL" _ + , MsgId := "The APSO extension could not be located in your LibreOffice installation." _ + , Comment := "SF_Exception.PythonShell error message" _ + & "APSO: to leave unchanged" _ + ) + ' SFUnitTests._NewUnitTest + .AddText( Context := "UNITTESTLIBRARY" _ + , MsgId := "The requested library could not be located.\n" _ + & "The UnitTest service has not been initialized.\n\n" _ + & "Library name : « %1 »" _ + , Comment := "SFUnitTest could not locate the library gven as argument\n" _ + & "%1: The name of the library" _ + ) + ' SFUnitTests.SF_UnitTest + .AddText( Context := "UNITTESTMETHOD" _ + , MsgId := "The method '%1' is unexpected in the current context.\n" _ + & "The UnitTest service cannot proceed further with the on-going test." _ + , Comment := "SFUnitTest finds a RunTest() call in a inappropriate location\n" _ + & "%1: The name of a method" _ + ) + End With + End If + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Root._LoadLocalizedInterface + +REM ----------------------------------------------------------------------------- +Public Function _Repr() As String +''' Convert the unique SF_Root instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Root] (MainFunction: xxx, Console: yyy lines, ServicesList)" + +Dim sRoot As String ' Return value +Const cstRoot = "[Root] (" + + sRoot = cstRoot & "MainFunction: " & MainFunction & ", Console: " & UBound(ConsoleLines) + 1 & " lines" _ + & ", Libraries:" & SF_Utils._Repr(ServicesList.Keys) _ + & ")" + + _Repr = sRoot + +End Function ' ScriptForge.SF_Root._Repr + +REM ----------------------------------------------------------------------------- +Public Sub _StackReset() +''' Reset private members after a fatal/abort error to leave +''' a stable persistent storage after an unwanted interrupt + + MainFunction = "" + MainFunctionArgs = "" + StackLevel = 0 + TriggeredByPython = False + +End Sub ' ScriptForge.SF_Root._StackReset + +REM ================================================== END OF SCRIPTFORGE.SF_ROOT + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Services.xba b/wizards/source/scriptforge/SF_Services.xba new file mode 100644 index 000000000..627dc4d2e --- /dev/null +++ b/wizards/source/scriptforge/SF_Services.xba @@ -0,0 +1,639 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Services +''' =========== +''' Singleton class implementing the "ScriptForge.Services" service +''' Implemented as a usual Basic module +''' The ScriptForge framework includes +''' the current ScriptForge library +''' a number of "associated" libraries +''' any user/contributor extension wanting to fit into the framework +''' The methods in this module constitute the kernel of the ScriptForge framework +''' - RegisterScriptServices +''' Register for a library the list of services it implements +''' Each library in the framework must implement its own RegisterScriptServices method +''' This method consists in a series of invocations of next 2 methods +''' - RegisterService +''' Register a single service +''' - RegisterEventManager +''' Register a single event manager +''' - CreateScriptService +''' Called by user scripts to get an object giving access to a service or to the event manager +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_services.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const UNKNOWNSERVICEERROR = "UNKNOWNSERVICEERROR" ' Service not found within the registered services of the given library +Const SERVICESNOTLOADEDERROR = "SERVICESNOTLOADEDERROR" ' Failure during the registering of the services of the given library +Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" ' Source file does not exist + +REM ============================================================== PUBLIC MEMBERS + +' Defines an entry in in the services dictionary +Type _Service + ServiceName As String + ServiceType As Integer + ' 0 Undefined + ' 1 Basic module + ' 2 Method reference as a string + ServiceReference As Object + ServiceMethod As String + EventManager As Boolean ' True if registered item is an event manager +End Type + +Private vServicesArray As Variant ' List of services registered by a library + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function CreateScriptService(Optional ByRef Service As Variant _ + , ParamArray pvArgs As Variant _ + ) As Variant +''' Create access to the services of a library for the benefit of a user script +''' A service is to understand either: +''' as a set of methods gathered in a Basic standard module +''' or a set of methods and properties gathered in a Basic class module +''' Args: +''' Service: the name of the service in 2 parts "library.service" +''' The library is a Basic library that must exist in the GlobalScope +''' (default = "ScriptForge") +''' The service is one of the services registered by the library +''' thru the RegisterScriptServices() routine +''' pvArgs: a set of arguments passed to the constructor of the service +''' This is only possible if the service refers to a Basic class module +''' Returns +''' The object containing either the reference of the Basic module +''' or of the Basic class instance +''' Both are Basic objects +''' Returns Nothing if an error occurred. +''' ==>> NOTE: The error can be within the user script creating the new class instance +''' Exceptions: +''' SERVICESNOTLOADEDERROR RegisterScriptService probable failure +''' UNKNOWNSERVICEERROR Service not found +''' Examples +''' CreateScriptService("Array") +''' => Refers to ScriptForge.Array or SF_Array +''' CreateScriptService("ScriptForge.Dictionary") +''' => Returns a new empty dictionary; "ScriptForge." is optional +''' CreateScriptService("SFDocuments.Calc") +''' => Refers to the Calc service, implemented in the SFDocuments library +''' CreateScriptService("Dialog", dlgName) +''' => Returns a Dialog instance referring to the dlgName dialog +''' CreateScriptService("SFDocuments.Event", oEvent) +''' => Refers to the Document service instance, implemented in the SFDocuments library, having triggered the event + +Dim vScriptService As Variant ' Return value +Dim vServiceItem As Variant ' A single service (see _Service type definition) +Dim vServicesList As Variant ' Output of RegisterScriptServices +Dim vSplit As Variant ' Array to split argument in +Dim sLibrary As String ' Library part of the argument +Dim sService As String ' Service part of the argument +Dim vLibrary As Variant ' Dictionary of libraries +Dim vService As Variant ' An individual service object +Const cstThisSub = "SF_Services.CreateScriptService" +Const cstSubArgs = "Service, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set vScriptService = Nothing + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Service, "Service", V_STRING) Then GoTo Catch + If Len(Service) = 0 Then GoTo CatchNotFound + End If + +Try: + ' Initialize the list of services when CreateScriptService called for the very 1st time + If IsEmpty(_SF_.ServicesList) Then _SF_.ServicesList = SF_Services._NewDictionary() + + ' Simple parsing of argument + vSplit = Split(Service, ".") + If UBound(vSplit) > 1 Then GoTo CatchNotFound + If UBound(vSplit) = 0 Then + sLibrary = "ScriptForge" ' Yes, the default value ! + sService = vSplit(0) + ' Accept other default values for associated libraries + Select Case LCase(sService) + Case "document", "calc", "writer", "base", "documentevent", "formevent" + sLibrary = "SFDocuments" + Case "dialog", "dialogevent" : sLibrary = "SFDialogs" + Case "database" : sLibrary = "SFDatabases" + Case "unittest" : sLibrary = "SFUnitTests" + Case "menu", "popupmenu" : sLibrary = "SFWidgets" + Case Else + End Select + Else + sLibrary = vSplit(0) + sService = vSplit(1) + End If + + With _SF_.ServicesList + + ' Load the set of services from the library, if not yet done + If Not .Exists(sLibrary) Then + If Not SF_Services._LoadLibraryServices(sLibrary) Then GoTo CatchNotLoaded + End If + + ' Find and return the requested service + vServicesList = .Item(sLibrary) + If Not vServicesList.Exists(sService) Then GoTo CatchNotFound + vServiceItem = vServicesList.Item(sService) + Select Case vServiceItem.ServiceType + Case 1 ' Basic module + vScriptService = vServiceItem.ServiceReference + Case 2 ' Method to call + If sLibrary = "ScriptForge" Then ' Direct call + Select Case UCase(sService) + Case "DICTIONARY" : vScriptService = SF_Services._NewDictionary() + Case "L10N" : vScriptService = SF_Services._NewL10N(pvArgs) + Case "TIMER" : vScriptService = SF_Services._NewTimer(pvArgs) + Case Else + End Select + Else ' Call via script provider + Set vService = SF_Session._GetScript("Basic", SF_Session.SCRIPTISAPPLICATION, vServiceItem.ServiceMethod) + vScriptService = vService.Invoke(Array(pvArgs()), Array(), Array()) + End If + Case Else + End Select + + End With + +Finally: + CreateScriptService = vScriptService + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + SF_Exception.RaiseFatal(UNKNOWNSERVICEERROR, "Service", Service, sLibrary, sService) + GoTo Finally +CatchNotLoaded: + SF_Exception.RaiseFatal(SERVICESNOTLOADEDERROR, "Service", Service, sLibrary) + GoTo Finally +End Function ' ScriptForge.SF_Services.CreateScriptService + +REM ----------------------------------------------------------------------------- +Public Function RegisterEventManager(Optional ByVal ServiceName As Variant _ + , Optional ByRef ServiceReference As Variant _ + ) As Boolean +''' Register into ScriptForge a new event entry for the library +''' from which this method is called +''' MUST BE CALLED ONLY from a specific RegisterScriptServices() method +''' Usually the method should be called only once by library +''' Args: +''' ServiceName: the name of the service as a string. It the service exists +''' already for the library the method overwrites the existing entry +''' ServiceReference: the function which will identify the source of the triggered event +''' something like: "libraryname.modulename.function" +''' Returns: +''' True if successful +''' Example: +''' ' Code snippet stored in a module contained in the SFDocuments library +''' Sub RegisterScriptServices() +''' ' Register the events manager of the library +''' RegisterEventManager("DocumentEvent", "SFDocuments.SF_Register._EventManager") +''' End Sub +''' ' Code snippet stored in a user script +''' Sub Trigger(poEvent As Object) ' Triggered by a DOCUMENTEVENT event +''' Dim myDoc As Object +''' ' To get the document concerned by the event: +''' Set myDoc = CreateScriptService("SFDocuments.DocumentEvent", poEvent) +''' End Sub + +Dim bRegister As Boolean ' Return value +Const cstThisSub = "SF_Services.RegisterEventManager" +Const cstSubArgs = "ServiceName, ServiceReference" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRegister = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(ServiceName, "ServiceName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(ServiceReference, "ServiceReference",V_STRING) Then GoTo Finally + End If + +Try: + bRegister = _AddToServicesArray(ServiceName, ServiceReference, True) + +Finally: + RegisterEventManager = bRegister + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Services.RegisterEventManager + +REM ----------------------------------------------------------------------------- +Public Function RegisterService(Optional ByVal ServiceName As Variant _ + , Optional ByRef ServiceReference As Variant _ + ) As Boolean +''' Register into ScriptForge a new service entry for the library +''' from which this method is called +''' MUST BE CALLED ONLY from a specific RegisterScriptServices() method +''' Args: +''' ServiceName: the name of the service as a string. It the service exists +''' already for the library the method overwrites the existing entry +''' ServiceReference: either +''' - the Basic module that implements the methods of the service +''' something like: GlobalScope.Library.Module +''' - an instance of the class implementing the methods and properties of the service +''' something like: "libraryname.modulename.function" +''' Returns: +''' True if successful + +Dim bRegister As Boolean ' Return value +Const cstThisSub = "SF_Services.RegisterService" +Const cstSubArgs = "ServiceName, ServiceReference" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRegister = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(ServiceName, "ServiceName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(ServiceReference, "ServiceReference", Array(V_STRING, V_OBJECT)) Then GoTo Finally + End If + +Try: + bRegister = _AddToServicesArray(ServiceName, ServiceReference, False) + +Finally: + RegisterService = bRegister + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Services.RegisterService + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' This method may be stored in any standard (i.e. not class-) module +''' +''' Each individual service is registered by calling the RegisterService() method +''' +''' The current version is given as an example +''' + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Array", GlobalScope.ScriptForge.SF_Array) ' Reference to the Basic module + .RegisterService("Dictionary", "ScriptForge.SF_Services._NewDictionary") ' Reference to the function initializing the service + .RegisterService("Exception", GlobalScope.ScriptForge.SF_Exception) + .RegisterService("FileSystem", GlobalScope.ScriptForge.SF_FileSystem) + .RegisterService("L10N", "ScriptForge.SF_Services._NewL10N") + .RegisterService("Platform", GlobalScope.ScriptForge.SF_Platform) + .RegisterService("Region", GlobalScope.ScriptForge.SF_Region) + .RegisterService("Session", GlobalScope.ScriptForge.SF_Session) + .RegisterService("String", GlobalScope.ScriptForge.SF_String) + .RegisterService("Timer", "ScriptForge.SF_Services._NewTimer") + .RegisterService("UI", GlobalScope.ScriptForge.SF_UI) + 'TODO + End With + +End Sub ' ScriptForge.SF_Services.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _AddToServicesArray(ByVal psServiceName As String _ + , ByRef pvServiceReference As Variant _ + , ByVal pbEvent As Boolean _ + ) As Boolean +''' Add the arguments as an additional row in vServicesArray (Public variable) +''' Called from RegisterService and RegisterEvent methods + +Dim bRegister As Boolean ' Return value +Dim lMax As Long ' Number of rows in vServicesArray + + bRegister = False + +Check: + ' Ignore when method is not called from RegisterScriptServices() + If IsEmpty(vServicesArray) Or IsNull(vServicesArray) Or Not IsArray(vServicesArray) Then GoTo Finally + +Try: + lMax = UBound(vServicesArray, 1) + 1 + If lMax <= 0 Then + ReDim vServicesArray(0 To 0, 0 To 2) + Else + ReDim Preserve vServicesArray(0 To lMax, 0 To 2) + End If + vServicesArray(lMax, 0) = psServiceName + vServicesArray(lMax, 1) = pvServiceReference + vServicesArray(lMax, 2) = pbEvent + bRegister = True + +Finally: + _AddToServicesArray = bRegister + Exit Function +End Function ' ScriptForge.SF_Services._AddToServicesArray + +REM ----------------------------------------------------------------------------- +Private Function _FindModuleFromMethod(ByVal psLibrary As String _ + , ByVal psMethod As String _ + ) As String +''' Find in the given library the name of the module containing +''' the method given as 2nd argument (usually RegisterScriptServices) +''' Args: +''' psLibrary: the name of the Basic library +''' psMethod: the method to locate +''' Returns: +''' The name of the module or a zero-length string if not found + +Dim vCategories As Variant ' "user" or "share" library categories +Dim sCategory As String +Dim vLanguages As Variant ' "Basic", "Python", ... programming languages +Dim sLanguage As String +Dim vLibraries As Variant ' Library names +Dim sLibrary As String +Dim vModules As Variant ' Module names +Dim sModule As String ' Return value +Dim vMethods As Variant ' Method/properties/subs/functions +Dim sMethod As String +Dim oRoot As Object ' com.sun.star.script.browse.BrowseNodeFactory +Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer + + _FindModuleFromMethod = "" + Set oRoot = SF_Utils._GetUNOService("BrowseNodeFactory").createView(com.sun.star.script.browse.BrowseNodeFactoryViewTypes.MACROORGANIZER) + + ' Exploration is done via tree nodes + If Not IsNull(oRoot) Then + If oRoot.hasChildNodes() Then + vCategories = oRoot.getChildNodes() + For i = 0 To UBound(vCategories) + sCategory = vCategories(i).getName() + ' Consider "My macros & Dialogs" and "LibreOffice Macros & Dialogs" only + If sCategory = "user" Or sCategory = "share" Then + If vCategories(i).hasChildNodes() Then + vLanguages = vCategories(i).getChildNodes() + For j = 0 To UBound(vLanguages) + sLanguage = vLanguages(j).getName() + ' Consider Basic libraries only + If sLanguage = "Basic" Then + If vLanguages(j).hasChildNodes() Then + vLibraries = vLanguages(j).getChildNodes() + For k = 0 To UBound(vLibraries) + sLibrary = vLibraries(k).getName() + ' Consider the given library only + If sLibrary = psLibrary Then + If vLibraries(k).hasChildNodes() Then + vModules = vLibraries(k).getChildNodes() + For l = 0 To UBound(vModules) + sModule = vModules(l).getName() + ' Check if the module contains the targeted method + If vModules(l).hasChildNodes() Then + vMethods = vModules(l).getChildNodes() + For m = 0 To UBound(vMethods) + sMethod = vMethods(m).getName() + If sMethod = psMethod Then + _FindModuleFromMethod = sModule + Exit Function + End If + Next m + End If + Next l + End If + End If + Next k + End If + End If + Next j + End If + End If + Next i + End If + End If + +End Function ' ScriptForge.SF_Services._FindModuleFromMethod + +REM ----------------------------------------------------------------------------- +Private Function _LoadLibraryServices(ByVal psLibrary As String) As Boolean +''' Execute psLibrary.RegisterScriptServices() and load its services into the persistent storage +''' Args: +''' psLibrary: the name of the Basic library +''' Library will be loaded if not yet done +''' Returns: +''' True if success +''' The list of services is loaded directly into the persistent storage + + +Dim vServicesList As Variant ' Dictionary of services +Dim vService As Variant ' Single service entry in dictionary +Dim vServiceItem As Variant ' Single service in vServicesArray +Dim sModule As String ' Name of module containing the RegisterScriptServices method +Dim i As Long +Const cstRegister = "RegisterScriptServices" + +Try: + _LoadLibraryServices = False + + vServicesArray = Array() + + If psLibrary = "ScriptForge" Then + ' Direct call + ScriptForge.SF_Services.RegisterScriptServices() + Else + ' Register services via script provider + If GlobalScope.BasicLibraries.hasByName(psLibrary) Then + If Not GlobalScope.BasicLibraries.isLibraryLoaded(psLibrary) Then + GlobalScope.BasicLibraries.LoadLibrary(psLibrary) + End If + Else + GoTo Finally + End If + sModule = SF_Services._FindModuleFromMethod(psLibrary, cstRegister) + If Len(sModule) = 0 Then GoTo Finally + SF_Session.ExecuteBasicScript(, psLibrary & "." & sModule & "." & cstRegister) + End If + + ' Store in persistent storage + ' - Create list of services for the current library + Set vServicesList = SF_Services._NewDictionary() + For i = 0 To UBound(vServicesArray, 1) + Set vService = New _Service + With vService + .ServiceName = vServicesArray(i, 0) + vServiceItem = vServicesArray(i, 1) + If VarType(vServiceItem) = V_STRING Then + .ServiceType = 2 + .ServiceMethod = vServiceItem + Set .ServiceReference = Nothing + Else ' OBJECT + .ServiceType = 1 + .ServiceMethod = "" + Set .ServiceReference = vServiceItem + End If + .EventManager = vServicesArray(i, 2) + End With + vServicesList.Add(vServicesArray(i, 0), vService) + Next i + ' - Add the new dictionary to the persistent dictionary + _SF_.ServicesList.Add(psLibrary, vServicesList) + _LoadLibraryServices = True + vServicesArray = Empty + +Finally: + Exit Function +End Function ' ScriptForge.SF_Services._LoadLibraryServices + +REM ----------------------------------------------------------------------------- +Public Function _NewDictionary() As Variant +''' Create a new instance of the SF_Dictionary class +''' Returns: the instance or Nothing + +Dim oDict As Variant + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + +Try: + Set oDict = New SF_Dictionary + Set oDict.[Me] = oDict + +Finally: + Set _NewDictionary = oDict + Exit Function +Catch: + Set oDict = Nothing + GoTo Finally +End Function ' ScriptForge.SF_Services._NewDictionary + +REM ----------------------------------------------------------------------------- +Public Function _NewL10N(Optional ByVal pvArgs As Variant) As Variant +''' Create a new instance of the SF_L10N class +' Args: +''' FolderName: the folder containing the PO files in SF_FileSystem.FileNaming notation +''' Locale: locale of user session (default) or any other valid la{nguage]-CO[UNTRY] combination +''' The country part is optional. Valid are f.i. "fr", "fr-CH", "en-US" +''' Encoding: The character set that should be used +''' Use one of the Names listed in https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Note that LibreOffice probably does not implement all existing sets +''' Default = UTF-8 +''' Locale2: fallback Locale to select if Locale po file does not exist (typically "en-US") +''' Encoding2: Encoding of the 2nd Locale file +''' Returns: the instance or Nothing +''' Exceptions: +''' UNKNOWNFILEERROR The PO file does not exist + +Dim oL10N As Variant ' Return value +Dim sFolderName As String ' Folder containing the PO files +Dim sLocale As String ' Passed argument or that of the user session +Dim sLocale2 As String ' Alias for Locale2 +Dim oLocale As Variant ' com.sun.star.lang.Locale +Dim sPOFile As String ' PO file must exist +Dim sEncoding As String ' Alias for Encoding +Dim sEncoding2 As String ' Alias for Encoding2 + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Then pvArgs = Array() + sPOFile = "" + sEncoding = "" + If UBound(pvArgs) >= 0 Then + If Not SF_Utils._ValidateFile(pvArgs(0), "Folder (Arg0)", , True) Then GoTo Catch + sFolderName = pvArgs(0) + sLocale = "" + If UBound(pvArgs) >= 1 Then + If Not SF_Utils._Validate(pvArgs(1), "Locale (Arg1)", V_STRING) Then GoTo Catch + sLocale = pvArgs(1) + End If + If Len(sLocale) = 0 Then ' Called from Python, the Locale argument may be the zero-length string + Set oLocale = SF_Utils._GetUNOService("OfficeLocale") + sLocale = oLocale.Language & "-" & oLocale.Country + End If + If UBound(pvArgs) >= 2 Then + If IsMissing(pvArgs(2)) Or IsEmpty(pvArgs(2)) Then pvArgs(2) = "UTF-8" + If Not SF_Utils._Validate(pvArgs(2), "Encoding (Arg2)", V_STRING) Then GoTo Catch + sEncoding = pvArgs(2) + Else + sEncoding = "UTF-8" + End If + sLocale2 = "" + If UBound(pvArgs) >= 3 Then + If Not SF_Utils._Validate(pvArgs(3), "Locale2 (Arg3)", V_STRING) Then GoTo Catch + sLocale2 = pvArgs(3) + End If + If UBound(pvArgs) >= 4 Then + If Not SF_Utils._Validate(pvArgs(4), "Encoding2 (Arg4)", V_STRING) Then GoTo Catch + sEncoding2 = pvArgs(4) + Else + sEncoding2 = "UTF-8" + End If + If Len(sFolderName) > 0 Then + sPOFile = SF_FileSystem.BuildPath(sFolderName, sLocale & ".po") + If Not SF_FileSystem.FileExists(sPOFile) Then + If Len(sLocale2) = 0 Then GoTo CatchNotExists ' No fallback => error + ' Try the fallback + sPOFile = SF_FileSystem.BuildPath(sFolderName, sLocale2 & ".po") + If Not SF_FileSystem.FileExists(sPOFile) Then GoTo CatchNotExists + sEncoding = sEncoding2 + End If + End If + End If + +Try: + Set oL10N = New SF_L10N + Set oL10N.[Me] = oL10N + oL10N._Initialize(sPOFile, sEncoding) + +Finally: + Set _NewL10N = oL10N + Exit Function +Catch: + Set oL10N = Nothing + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", sPOFile) + GoTo Finally +End Function ' ScriptForge.SF_Services._NewL10N + +REM ----------------------------------------------------------------------------- +Public Function _NewTimer(Optional ByVal pvArgs As Variant) As Variant +''' Create a new instance of the SF_Timer class +''' Args: +''' [0] : If True, start the timer immediately +''' Returns: the instance or Nothing + +Dim oTimer As Variant ' Return value +Dim bStart As Boolean ' Automatic start ? + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) < 0 Then + bStart = False + Else + If Not SF_Utils._Validate(pvArgs(0), "Start (Arg0)", V_BOOLEAN) Then GoTo Catch + bStart = pvArgs(0) + End If +Try: + Set oTimer = New SF_Timer + Set oTimer.[Me] = oTimer + If bStart Then oTimer.Start() + +Finally: + Set _NewTimer = oTimer + Exit Function +Catch: + Set oTimer = Nothing + GoTo Finally +End Function ' ScriptForge.SF_Services._NewTimer + +REM ============================================== END OF SCRIPTFORGE.SF_SERVICES + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Session.xba b/wizards/source/scriptforge/SF_Session.xba new file mode 100644 index 000000000..b4292f36e --- /dev/null +++ b/wizards/source/scriptforge/SF_Session.xba @@ -0,0 +1,1076 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Session +''' ========== +''' Singleton class implementing the "ScriptForge.Session" service +''' Implemented as a usual Basic module +''' +''' Gathers diverse general-purpose properties and methods about : +''' - installation/execution environment +''' - UNO introspection utilities +''' - clipboard management +''' - invocation of external scripts or programs +''' +''' Service invocation example: +''' Dim session As Variant +''' session = CreateScriptService("Session") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_session.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const CALCFUNCERROR = "CALCFUNCERROR" ' Calc function execution failed +Const NOSCRIPTERROR = "NOSCRIPTERROR" ' Script could not be located +Const SCRIPTEXECERROR = "SCRIPTEXECERROR" ' Exception during script execution +Const WRONGEMAILERROR = "WRONGEMAILERROR" ' Wrong email address +Const SENDMAILERROR = "SENDMAILERROR" ' Mail could not be sent +Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" ' Source file does not exist + +REM ============================================================ MODULE CONSTANTS + +''' Script locations +''' ================ +''' Use next constants as Scope argument when invoking next methods: +''' ExecuteBasicScript() +''' ExecutePythonScript() +''' Example: +''' session.ExecuteBasicScript(session.SCRIPTISEMBEDDED, "Standard.myModule.myFunc", etc) + +Const cstSCRIPTISEMBEDDED = "document" ' a library of the document (BASIC + PYTHON) +Const cstSCRIPTISAPPLICATION = "application" ' a shared library (BASIC) +Const cstSCRIPTISPERSONAL = "user" ' a library of My Macros (PYTHON) +Const cstSCRIPTISPERSOXT = "user:uno_packages" ' an extension for the current user (PYTHON) +Const cstSCRIPTISSHARED = "share" ' a library of LibreOffice Macros (PYTHON) +Const cstSCRIPTISSHAROXT = "share:uno_packages" ' an extension for all users (PYTHON) +Const cstSCRIPTISOXT = "uno_packages" ' an extension but install params are unknown (PYTHON) + +''' To build or to parse scripting framework URI's +Const cstScript1 = "vnd.sun.star.script:" +Const cstScript2 = "?language=" +Const cstScript3 = "&location=" + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_Array Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_Session" +End Property ' ScriptForge.SF_Session.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.Session" +End Property ' ScriptForge.SF_Array.ServiceName + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISAPPLICATION As String +''' Convenient constants + SCRIPTISAPPLICATION = cstSCRIPTISAPPLICATION +End Property ' ScriptForge.SF_Session.SCRIPTISAPPLICATION + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISEMBEDDED As String +''' Convenient constants + SCRIPTISEMBEDDED = cstSCRIPTISEMBEDDED +End Property ' ScriptForge.SF_Session.SCRIPTISEMBEDDED + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISOXT As String +''' Convenient constants + SCRIPTISOXT = cstSCRIPTISOXT +End Property ' ScriptForge.SF_Session.SCRIPTISOXT + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISPERSONAL As String +''' Convenient constants + SCRIPTISPERSONAL = cstSCRIPTISPERSONAL +End Property ' ScriptForge.SF_Session.SCRIPTISPERSONAL + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISPERSOXT As String +''' Convenient constants + SCRIPTISPERSOXT = cstSCRIPTISPERSOXT +End Property ' ScriptForge.SF_Session.SCRIPTISPERSOXT + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISSHARED As String +''' Convenient constants + SCRIPTISSHARED = cstSCRIPTISSHARED +End Property ' ScriptForge.SF_Session.SCRIPTISSHARED + +REM ----------------------------------------------------------------------------- +Property Get SCRIPTISSHAROXT As String +''' Convenient constants + SCRIPTISSHAROXT = cstSCRIPTISSHAROXT +End Property ' ScriptForge.SF_Session.SCRIPTISSHAROXT + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function ExecuteBasicScript(Optional ByVal Scope As Variant _ + , Optional ByVal Script As Variant _ + , ParamArray pvArgs As Variant _ + ) As Variant +''' Execute the Basic script given as a string and return the value returned by the script +''' Args: +''' Scope: "Application" (default) or "Document" (NOT case-sensitive) +''' (or use one of the SCRIPTIS... public constants above) +''' Script: library.module.method (Case sensitive) +''' library => The library may be not loaded yet +''' module => Must not be a class module +''' method => Sub or Function +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' pvArgs: the arguments of the called script +''' Returns: +''' The value returned by the call to the script +''' Exceptions: +''' NOSCRIPTERROR The script could not be found +''' Examples: +''' session.ExecuteBasicScript(, "XrayTool._Main.Xray", someuno) ' Sub: no return expected + +Dim oScript As Object ' Script to be invoked +Dim vReturn As Variant ' Returned value + +Const cstThisSub = "Session.ExecuteBasicScript" +Const cstSubArgs = "[Scope], Script, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + vReturn = Empty + +Check: + If IsMissing(Scope) Or IsEmpty(Scope) Then Scope = SCRIPTISAPPLICATION + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Scope, "Scope", V_STRING _ + , Array(SCRIPTISAPPLICATION, SCRIPTISEMBEDDED)) Then GoTo Finally + If Not SF_Utils._Validate(Script, "Script", V_STRING) Then GoTo Finally + End If + +Try: + ' Execute script + Set oScript = SF_Session._GetScript("Basic", Scope, Script) + On Local Error GoTo CatchExec + If Not IsNull(oScript) Then vReturn = oScript.Invoke(pvArgs, Array(), Array()) + +Finally: + ExecuteBasicScript = vReturn + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchExec: + SF_Exception.RaiseFatal(SCRIPTEXECERROR, "Script", Script, Error$) + GoTo Finally +End Function ' ScriptForge.SF_Session.ExecuteBasicScript + +REM ----------------------------------------------------------------------------- +Public Function ExecuteCalcFunction(Optional ByVal CalcFunction As Variant _ + , ParamArray pvArgs As Variant _ + ) As Variant +''' Execute a Calc function by its (english) name and based on the given arguments +''' Args: +''' CalcFunction: the english name of the function to execute +''' pvArgs: the arguments of the called function +''' Each argument must be either a string, a numeric value +''' or an array of arrays combining those types +''' Returns: +''' The (string or numeric) value or the array of arrays returned by the call to the function +''' When the arguments contain arrays, the function is executed as an array function +''' Wrong arguments generate an error +''' Exceptions: +''' CALCFUNCERROR ' Execution error in calc function +''' Examples: +''' session.ExecuteCalcFunction("AVERAGE", 1, 5, 3, 7) returns 4 +''' session.ExecuteCalcFunction("ABS", Array(Array(-1,2,3),Array(4,-5,6),Array(7,8,-9)))(2)(2) returns 9 +''' session.ExecuteCalcFunction("LN", -3) generates an error + +Dim oCalc As Object ' Give access to the com.sun.star.sheet.FunctionAccess service +Dim vReturn As Variant ' Returned value +Const cstThisSub = "Session.ExecuteCalcFunction" +Const cstSubArgs = "CalcFunction, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vReturn = Empty + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(CalcFunction, "CalcFunction", V_STRING) Then GoTo Finally + End If + +Try: + ' Execute function + Set oCalc = SF_Utils._GetUNOService("FunctionAccess") + ' Intercept calls from Python when no arguments. Example NOW() + If UBound(pvArgs) = 0 Then + If IsEmpty(pvArgs(0)) Then pvArgs = Array() + End If + On Local Error GoTo CatchCall + vReturn = oCalc.callFunction(UCase(CalcFunction), pvArgs()) + +Finally: + ExecuteCalcFunction = vReturn + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchCall: + SF_Exception.RaiseFatal(CALCFUNCERROR, CalcFunction) + GoTo Finally +End Function ' ScriptForge.SF_Session.ExecuteCalcFunction + +REM ----------------------------------------------------------------------------- +Public Function ExecutePythonScript(Optional ByVal Scope As Variant _ + , Optional ByVal Script As Variant _ + , ParamArray pvArgs As Variant _ + ) As Variant +''' Execute the Python script given as a string and return the value returned by the script +''' Args: +''' Scope: one of the SCRIPTIS... public constants above (default = "share") +''' Script: (Case sensitive) +''' "library/module.py$method" +''' or "module.py$method" +''' or "myExtension.oxt|myScript|module.py$method" +''' library => The library may be not loaded yet +''' myScript => The directory containing the python module +''' module.py => The python module +''' method => The python function +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' pvArgs: the arguments of the called script +''' Date arguments are converted to iso format. However dates in arrays are not converted +''' Returns: +''' The value(s) returned by the call to the script. If >1 values, enclosed in an array +''' Exceptions: +''' NOSCRIPTERROR The script could not be found +''' Examples: +''' session.ExecutePythonScript(session.SCRIPTISSHARED, "Capitalise.py$getNewString", "Abc") returns "abc" + +Dim oScript As Object ' Script to be invoked +Dim vArg As Variant ' Individual argument +Dim vReturn As Variant ' Returned value +Dim i As Long + +Const cstThisSub = "Session.ExecutePythonScript" +Const cstSubArgs = "[Scope], Script, arg0[, arg1] ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + vReturn = Empty + +Check: + If IsError(Scope) Or IsMissing(Scope) Then Scope = SCRIPTISSHARED + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Scope, "Scope", V_STRING _ + , Array(SCRIPTISSHARED, SCRIPTISEMBEDDED, SCRIPTISPERSONAL, SCRIPTISSHAROXT, SCRIPTISPERSOXT, SCRIPTISOXT) _ + ) Then GoTo Finally + If Not SF_Utils._Validate(Script, "Script", V_STRING) Then GoTo Finally + End If + +Try: + ' Filter date arguments - NB: dates in arrays are not filtered + For i = 0 To UBound(pvArgs) ' pvArgs always zero-based + vArg = pvArgs(i) + If VarType(vArg) = V_DATE Then pvArgs(i) = SF_Utils._CDateToIso(vArg) + Next i + + ' Intercept alternate Python helpers file when relevant + With _SF_ + If SF_String.StartsWith(Script, .PythonHelper) And Len(.PythonHelper2) > 0 Then + Scope = SCRIPTISPERSONAL + Script = .PythonHelper2 & Mid(Script, Len(.PythonHelper) + 1) + End If + End With + ' Find script + Set oScript = SF_Session._GetScript("Python", Scope, Script) + + ' Execute script + If Not IsNull(oScript) Then + vReturn = oScript.Invoke(pvArgs(), Array(), Array()) + ' Remove surrounding array when single returned value + If IsArray(vReturn) Then + If UBound(vReturn) = 0 Then vReturn = vReturn(0) + End If + End If + +Finally: + ExecutePythonScript = vReturn + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.ExecutePythonScript + +REM ----------------------------------------------------------------------------- +Public Function GetPDFExportOptions() As Variant +''' Return the actual values of the PDF export options +''' The PDF options are described on https://wiki.openoffice.org/wiki/API/Tutorials/PDF_export +''' PDF options are set at each use of the Export as ... PDF command by the user and kept +''' permanently until their reset by script or by a new export +''' Args: +''' Returns: +''' A ScriptForge dictionary instance listing the 40+ properties and their value +''' Examples: +''' Dim dict As Object +''' Set dict = session.GetPDFExportOptions() +''' MsgBox dict.Item("Quality") + +Dim vDict As Variant ' Returned value +Dim oConfig As Object ' com.sun.star.configuration.ConfigurationProvider +Dim oNodePath As Object ' com.sun.star.beans.PropertyValue +Dim oOptions As Object ' configmgr.RootAccess +Dim vOptionNames As Variant ' Array of PDF options names +Dim vOptionValues As Variant ' Array of PDF options values +Dim i As Long + +Const cstThisSub = "Session.GetPDFExportOptions" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set vDict = Nothing + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + ' Get the (read-only) internal PDF options + Set oConfig = SF_Utils._GetUNOService("ConfigurationProvider") + Set oNodePath = SF_Utils._MakePropertyValue("nodepath", "/org.openoffice.Office.Common/Filter/PDF/Export/") + Set oOptions = oConfig.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", Array(oNodePath)) + + ' Copy the options into a ScriptForge dictionary + Set vDict = CreateScriptService("dictionary") + vOptionNames = oOptions.getElementNames() + vOptionValues = oOptions.getPropertyValues(vOptionNames) + ' + For i = 0 To UBound(vOptionNames) + vDict.Add(vOptionNames(i), vOptionValues(i)) + Next i + + +Finally: + GetPDFExportOptions = vDict + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.GetPDFExportOptions + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Session.GetProperty" +Const cstSubArgs = "PropertyName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function HasUnoMethod(Optional ByRef UnoObject As Variant _ + , Optional ByVal MethodName As Variant _ + ) As Boolean +''' Returns True if a UNO object contains the given method +''' Code-snippet derived from XRAY +''' Args: +''' UnoObject: the object to identify +''' MethodName: the name of the method as a string. The search is case-sensitive +''' Returns: +''' False when the method is not found or when an argument is invalid + +Dim oIntrospect As Object ' com.sun.star.beans.Introspection +Dim oInspect As Object ' com.sun.star.beans.XIntrospectionAccess +Dim bMethod As Boolean ' Return value +Const cstThisSub = "Session.HasUnoMethod" +Const cstSubArgs = "UnoObject, MethodName" + + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Check: + bMethod = False + If VarType(UnoObject) <> V_OBJECT Then GoTo Finally + If IsNull(UnoObject) Then GoTo Finally + If VarType(MethodName) <> V_STRING Then GoTo Finally + If MethodName = Space(Len(MethodName)) Then GoTo Finally + +Try: + On Local Error GoTo Catch + Set oIntrospect = SF_Utils._GetUNOService("Introspection") + Set oInspect = oIntrospect.inspect(UnoObject) + bMethod = oInspect.hasMethod(MethodName, com.sun.star.beans.MethodConcept.ALL) + +Finally: + HasUnoMethod = bMethod + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + On Local Error GoTo 0 + GoTo Finally +End Function ' ScriptForge.SF_Session.HasUnoMethod + +REM ----------------------------------------------------------------------------- +Public Function HasUnoProperty(Optional ByRef UnoObject As Variant _ + , Optional ByVal PropertyName As Variant _ + ) As Boolean +''' Returns True if a UNO object contains the given property +''' Code-snippet derived from XRAY +''' Args: +''' UnoObject: the object to identify +''' PropertyName: the name of the property as a string. The search is case-sensitive +''' Returns: +''' False when the property is not found or when an argument is invalid + +Dim oIntrospect As Object ' com.sun.star.beans.Introspection +Dim oInspect As Object ' com.sun.star.beans.XIntrospectionAccess +Dim bProperty As Boolean ' Return value +Const cstThisSub = "Session.HasUnoProperty" +Const cstSubArgs = "UnoObject, PropertyName" + + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Check: + bProperty = False + If VarType(UnoObject) <> V_OBJECT Then GoTo Finally + If IsNull(UnoObject) Then GoTo Finally + If VarType(PropertyName) <> V_STRING Then GoTo Finally + If PropertyName = Space(Len(PropertyName)) Then GoTo Finally + +Try: + On Local Error GoTo Catch + Set oIntrospect = SF_Utils._GetUNOService("Introspection") + Set oInspect = oIntrospect.inspect(UnoObject) + bProperty = oInspect.hasProperty(PropertyName, com.sun.star.beans.PropertyConcept.ALL) + +Finally: + HasUnoProperty = bProperty + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + On Local Error GoTo 0 + GoTo Finally +End Function ' ScriptForge.SF_Session.HasUnoProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Session service as an array + + Methods = Array( _ + "ExecuteBasicScript" _ + , "ExecuteCalcFunction" _ + , "ExecutePythonScript" _ + , "HasUnoMethod" _ + , "HasUnoProperty" _ + , "OpenURLInBrowser" _ + , "RunApplication" _ + , "SendMail" _ + , "UnoMethods" _ + , "UnoObjectType" _ + , "UnoProperties" _ + , "WebService" _ + ) + +End Function ' ScriptForge.SF_Session.Methods + +REM ----------------------------------------------------------------------------- +Public Sub OpenURLInBrowser(Optional ByVal URL As Variant) +''' Opens a URL in the default browser +''' Args: +''' URL: The URL to open in the browser +''' Examples: +''' session.OpenURLInBrowser("https://docs.python.org/3/library/webbrowser.html") + +Const cstPyHelper = "$" & "_SF_Session__OpenURLInBrowser" + +Const cstThisSub = "Session.OpenURLInBrowser" +Const cstSubArgs = "URL" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(URL, "URL", V_STRING) Then GoTo Finally + End If + +Try: + ExecutePythonScript(SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, URL) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_Session.OpenURLInBrowser + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties as an array + + Properties = Array( _ + ) + +End Function ' ScriptForge.SF_Session.Properties + +REM ----------------------------------------------------------------------------- +Public Function RunApplication(Optional ByVal Command As Variant _ + , Optional ByVal Parameters As Variant _ + ) As Boolean +''' Executes an arbitrary system command +''' Args: +''' Command: The command to execute +''' This may be an executable file or a document which is registered with an application +''' so that the system knows what application to launch for that document +''' Parameters: a list of space separated parameters as a single string +''' The method does not validate the given parameters, but only passes them to the specified command +''' Returns: +''' True if success +''' Examples: +''' session.RunApplication("Notepad.exe") +''' session.RunApplication("C:\myFolder\myDocument.odt") +''' session.RunApplication("kate", "/home/me/install.txt") ' (Linux) + +Dim bReturn As Boolean ' Returned value +Dim oShell As Object ' com.sun.star.system.SystemShellExecute +Dim sCommand As String ' Command as an URL +Const cstThisSub = "Session.RunApplication" +Const cstSubArgs = "Command, [Parameters]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bReturn = False + +Check: + If IsMissing(Parameters) Then Parameters = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(Command, "Command") Then GoTo Finally + If Not SF_Utils._Validate(Parameters, "Parameters", V_STRING) Then GoTo Finally + End If + +Try: + Set oShell = SF_Utils._GetUNOService("SystemShellExecute") + sCommand = SF_FileSystem._ConvertToUrl(Command) + oShell.execute(sCommand, Parameters, com.sun.star.system.SystemShellExecuteFlags.URIS_ONLY) + bReturn = True + +Finally: + RunApplication = bReturn + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.RunApplication + +REM ----------------------------------------------------------------------------- +Public Sub SendMail(Optional ByVal Recipient As Variant _ + , Optional ByRef Cc As Variant _ + , Optional ByRef Bcc As Variant _ + , Optional ByVal Subject As Variant _ + , Optional ByRef Body As Variant _ + , Optional ByVal FileNames As Variant _ + , Optional ByVal EditMessage As Variant _ + ) +''' Send a message (with or without attachments) to recipients from the user's mail client +''' The message may be edited by the user before sending or, alternatively, be sent immediately +''' Args: +''' Recipient: an email addresses (To recipient) +''' Cc: a comma-delimited list of email addresses (carbon copy) +''' Bcc: a comma-delimited list of email addresses (blind carbon copy) +''' Subject: the header of the message +''' FileNames: a comma-separated list of filenames to attach to the mail. SF_FileSystem naming conventions apply +''' Body: the unformatted text of the message +''' EditMessage: when True (default) the message is editable before being sent +''' Exceptions: +''' UNKNOWNFILEERROR File does not exist +''' WRONGEMAILERROR String not recognized as an email address +''' SENDMAILERROR System error, probably no mail client + +Dim sEmail As String ' An single email address +Dim sFile As String ' A single file name +Dim sArg As String ' Argument name +Dim vCc As Variant ' Array alias of Cc +Dim vBcc As Variant ' Array alias of Bcc +Dim vFileNames As Variant ' Array alias of FileNames +Dim oMailService As Object ' com.sun.star.system.SimpleCommandMail or com.sun.star.system.SimpleSystemMail +Dim oMail As Object ' com.sun.star.system.XSimpleMailClient +Dim oMessage As Object ' com.sun.star.system.XSimpleMailMessage +Dim lFlag As Long ' com.sun.star.system.SimpleMailClientFlags.XXX +Dim ARR As Object : ARR = ScriptForge.SF_Array +Dim i As Long +Const cstComma = ",", cstSemiColon = ";" +Const cstThisSub = "Session.SendMail" +Const cstSubArgs = "Recipient, [Cc=""""], [Bcc=""""], [Subject=""""], [FileNames=""""], [Body=""""], [EditMessage=True]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Cc) Or IsEmpty(Cc) Then Cc = "" + If IsMissing(Bcc) Or IsEmpty(Bcc) Then Bcc = "" + If IsMissing(Subject) Or IsEmpty(Subject) Then Subject = "" + If IsMissing(FileNames) Or IsEmpty(FileNames) Then FileNames = "" + If IsMissing(Body) Or IsEmpty(Body) Then Body = "" + If IsMissing(EditMessage) Or IsEmpty(EditMessage) Then EditMessage = True + + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Cc, "Recipient", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Cc, "Cc", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Bcc, "Bcc", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Subject, "Subject", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FileNames, "FileNames", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Body, "Body", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(EditMessage, "EditMessage", V_BOOLEAN) Then GoTo Finally + End If + + ' Check email addresses + sArg = "Recipient" : sEmail = Recipient + If Not SF_String.IsEmail(sEmail) Then GoTo CatchEmail + sArg = "Cc" : vCc = ARR.TrimArray(Split(Cc, cstComma)) + For Each sEmail In vCc + If Not SF_String.IsEmail(sEmail) Then GoTo CatchEmail + Next sEmail + sArg = "Bcc" : vBcc = ARR.TrimArray(Split(Bcc, cstComma)) + For Each sEmail In vBcc + If Not SF_String.IsEmail(sEmail) Then GoTo CatchEmail + Next sEmail + + ' Check file existence + If Len(FileNames) > 0 Then + vFileNames = ARR.TrimArray(Split(FileNames, cstComma)) + For i = 0 To UBound(vFileNames) + sFile = vFileNames(i) + If Not SF_Utils._ValidateFile(sFile, "FileNames") Then GoTo Finally + If Not SF_FileSystem.FileExists(sFile) Then GoTo CatchNotExists + vFileNames(i) = ConvertToUrl(sFile) + Next i + End If + +Try: + ' Initialize the mail service + Set oMailService = SF_Utils._GetUNOService("MailService") + If IsNull(oMailService) Then GoTo CatchMail + Set oMail = oMailService.querySimpleMailClient() + If IsNull(oMail) Then GoTo CatchMail + Set oMessage = oMail.createSimpleMailMessage() + If IsNull(oMessage) Then GoTo CatchMail + + ' Feed the new mail message + With oMessage + .setRecipient(Recipient) + If Subject <> "" Then .setSubject(Subject) + If UBound(vCc) >= 0 Then .setCcRecipient(vCc) + If UBound(vBcc) >= 0 Then .setBccRecipient(vBcc) + .Body = Iif(Len(Body) = 0, " ", Body) ' Body must not be the empty string ?? + .setAttachement(vFileNames) + End With + lFlag = Iif(EditMessage, com.sun.star.system.SimpleMailClientFlags.DEFAULTS, com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE) + + ' Send using the mail service + oMail.sendSimpleMailMessage(oMessage, lFlag) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +CatchEmail: + SF_Exception.RaiseFatal(WRONGEMAILERROR, sArg, sEmail) + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileNames", sFile) + GoTo Finally +CatchMail: + SF_Exception.RaiseFatal(SENDMAILERROR) + GoTo Finally +End Sub ' ScriptForge.SF_Session.SendMail + +REM ----------------------------------------------------------------------------- +Public Function SetPDFExportOptions(Optional ByRef PDFOptions As Variant) As Boolean +''' Modify the actual values of the PDF export options from an options dictionary +''' The PDF options are described on https://wiki.openoffice.org/wiki/API/Tutorials/PDF_export +''' PDF options are set at each use of the Export as ... PDF command by the user and kept +''' permanently until their reset by script (like this one) or by a new export +''' The changed options are applicable on any subsequent ExportToPDF user command or to any SaveAsPDF script execution +''' Args: +''' PDFOptions: a ScriptForge dictionary object +''' Returns: +''' True when successful +''' Examples: +''' Dim dict As Object +''' Set dict = session.GetPDFExportOptions() +''' dict.ReplaceItem("Quality", 50) +''' session.SetPDFExportOptions(dict) + +Dim bSetPDF As Boolean ' Returned value +Dim oConfig As Object ' com.sun.star.configuration.ConfigurationProvider +Dim oNodePath As Object ' com.sun.star.beans.PropertyValue +Dim oOptions As Object ' configmgr.RootAccess +Dim vOptionNames As Variant ' Array of PDF options names +Dim vOptionValues As Variant ' Array of PDF options values +Dim oDict As Object ' Alias of PDFOptions +Dim i As Long + +Const cstThisSub = "Session.SetPDFExportOptions" +Const cstSubArgs = "PDFOptions" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSetPDF = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PDFOptions, "PDFOptions", V_OBJECT, , , "DICTIONARY") Then GoTo Finally + End If + +Try: + ' Get the (updatable) internal PDF options + Set oConfig = SF_Utils._GetUNOService("ConfigurationProvider") + Set oNodePath = SF_Utils._MakePropertyValue("nodepath", "/org.openoffice.Office.Common/Filter/PDF/Export/") + Set oOptions = oConfig.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", Array(oNodePath)) + + ' Copy the options from the ScriptForge dictionary in argument to property values + Set oDict = PDFOptions + oOptions.setPropertyValues(oDict.Keys, oDict.Items) + oOptions.commitChanges() + + bSetPDF = True + +Finally: + SetPDFExportOptions = bSetPDF + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.SetPDFExportOptions + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Session.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function UnoMethods(Optional ByRef UnoObject As Variant) As Variant +''' Returns a list of the methods callable from an UNO object +''' Code-snippet derived from XRAY +''' Args: +''' UnoObject: the object to identify +''' Returns: +''' A zero-based sorted array. May be empty + +Dim oIntrospect As Object ' com.sun.star.beans.Introspection +Dim oInspect As Object ' com.sun.star.beans.XIntrospectionAccess +Dim vMethods As Variant ' Array of com.sun.star.reflection.XIdlMethod +Dim vMethod As Object ' com.sun.star.reflection.XIdlMethod +Dim lMax As Long ' UBounf of vMethods +Dim vMethodsList As Variant ' Return value +Dim i As Long +Const cstThisSub = "Session.UnoMethods" +Const cstSubArgs = "UnoObject" + + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Check: + vMethodsList = Array() + If VarType(UnoObject) <> V_OBJECT Then GoTo Finally + If IsNull(UnoObject) Then GoTo Finally + +Try: + On Local Error GoTo Catch + Set oIntrospect = SF_Utils._GetUNOService("Introspection") + Set oInspect = oIntrospect.inspect(UnoObject) + vMethods = oInspect.getMethods(com.sun.star.beans.MethodConcept.ALL) + + ' The names must be extracted from com.sun.star.reflection.XIdlMethod structures + lMax = UBound(vMethods) + If lMax >= 0 Then + ReDim vMethodsList(0 To lMax) + For i = 0 To lMax + vMethodsList(i) = vMethods(i).Name + Next i + vMethodsList = SF_Array.Sort(vMethodsList, CaseSensitive := True) + End If + +Finally: + UnoMethods = vMethodsList + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + On Local Error GoTo 0 + GoTo Finally +End Function ' ScriptForge.SF_Session.UnoMethods + +REM ----------------------------------------------------------------------------- +Public Function UnoObjectType(Optional ByRef UnoObject As Variant) As String +''' Identify the UNO type of an UNO object +''' Code-snippet derived from XRAY +''' Args: +''' UnoObject: the object to identify +''' Returns: +''' com.sun.star. ... as a string +''' a zero-length string if identification was not successful + +Dim oObjDesc As Object ' _ObjectDescriptor type +Dim sObjectType As String ' Return value +Const cstThisSub = "Session.UnoObjectType" +Const cstSubArgs = "UnoObject" + + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Check: + sObjectType = "" + If VarType(UnoObject) <> V_OBJECT Then GoTo Finally + If IsNull(UnoObject) Then GoTo Finally + +Try: + Set oObjDesc = SF_Utils._VarTypeObj(UnoObject) + If oObjDesc.iVarType = V_UNOOBJECT Then sObjectType = oObjDesc.sObjectType + +Finally: + UnoObjectType = sObjectType + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Session.UnoObjectType + +REM ----------------------------------------------------------------------------- +Public Function UnoProperties(Optional ByRef UnoObject As Variant) As Variant +''' Returns a list of the properties of an UNO object +''' Code-snippet derived from XRAY +''' Args: +''' UnoObject: the object to identify +''' Returns: +''' A zero-based sorted array. May be empty + +Dim oIntrospect As Object ' com.sun.star.beans.Introspection +Dim oInspect As Object ' com.sun.star.beans.XIntrospectionAccess +Dim vProperties As Variant ' Array of com.sun.star.beans.Property +Dim vProperty As Object ' com.sun.star.beans.Property +Dim lMax As Long ' UBounf of vProperties +Dim vPropertiesList As Variant ' Return value +Dim i As Long +Const cstThisSub = "Session.UnoProperties" +Const cstSubArgs = "UnoObject" + + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Check: + vPropertiesList = Array() + If VarType(UnoObject) <> V_OBJECT Then GoTo Finally + If IsNull(UnoObject) Then GoTo Finally + +Try: + On Local Error GoTo Catch + Set oIntrospect = SF_Utils._GetUNOService("Introspection") + Set oInspect = oIntrospect.inspect(UnoObject) + vProperties = oInspect.getProperties(com.sun.star.beans.PropertyConcept.ALL) + + ' The names must be extracted from com.sun.star.beans.Property structures + lMax = UBound(vProperties) + If lMax >= 0 Then + ReDim vPropertiesList(0 To lMax) + For i = 0 To lMax + vPropertiesList(i) = vProperties(i).Name + Next i + vPropertiesList = SF_Array.Sort(vPropertiesList, CaseSensitive := True) + End If + +Finally: + UnoProperties = vPropertiesList + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + On Local Error GoTo 0 + GoTo Finally +End Function ' ScriptForge.SF_Session.UnoProperties + +REM ----------------------------------------------------------------------------- +Public Function WebService(Optional ByVal URI As Variant) As String +''' Get some web content from a URI +''' Args: +''' URI: URI text of the web service +''' Returns: +''' The web page content of the URI +''' Exceptions: +''' CALCFUNCERROR +''' Examples: +''' session.WebService("wiki.documentfoundation.org/api.php?" _ +''' & "hidebots=1&days=7&limit=50&action=feedrecentchanges&feedformat=rss") + +Dim sReturn As String ' Returned value +Const cstThisSub = "Session.WebService" +Const cstSubArgs = "URI" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sReturn = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(URI, "URI", V_STRING) Then GoTo Finally + End If + +Try: + sReturn = SF_Session.ExecuteCalcFunction("WEBSERVICE", URI) + +Finally: + WebService = sReturn + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Session.WebService + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _ExecuteScript(ByVal psScript As String _ + , Optional ByRef pvArg As Variant _ + ) As Variant +''' Execute the script expressed in the scripting framework_URI notation +''' Args: +''' psScript: read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' pvArg: the unique argument to pass to the called script. +''' It is often an event object that triggered the execution of the script. +''' Returns: +''' The return value after the script execution. May be ignored for events + +Dim sScope As String ' The scope part of the script URI +Dim sLanguage As String ' The language part of the script URI +Dim sScript As String ' The script part of the script URI +Dim vStrings As Variant ' Array of strings: (script, language, scope) +Const cstComma = "," + +Try: + If ScriptForge.SF_String.StartsWith(psScript, cstScript1) Then + ' Parse script + vStrings = Split( _ + Replace( _ + Replace(Mid(psScript, Len(cstScript1) + 1), cstScript2, cstComma) _ + , cstScript3, cstComma) _ + , cstComma) + sScript = vStrings(0) : sLanguage = vStrings(1) : sScope = vStrings(2) + ' Execute script + If UCase(sLanguage) = "BASIC" Then + _ExecuteScript = ExecuteBasicScript(sScope, sScript, pvArg) + Else ' Python + _ExecuteScript = ExecutePythonScript(sScope, sScript, pvArg) + End If + End If + +End Function ' ScriptForge.SF_Session._ExecuteScript + +REM ----------------------------------------------------------------------------- +Private Function _GetScript(ByVal psLanguage As String _ + , ByVal psScope As String _ + , ByVal psScript As String _ + ) As Object +''' Get the adequate script provider and from there the requested script +''' Called by ExecuteBasicScript() and ExecutePythonScript() +''' The execution of the script is done by the caller +''' Args: +''' psLanguage: Basic or Python +''' psScope: one of the SCRIPTISxxx constants +''' The SCRIPTISOXT constant is an alias for 2 cases, extension either +''' installed for one user only, or for all users +''' Managed here by trial and error +''' psScript: Read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' Returns: +''' A com.sun.star.script.provider.XScript object + +Dim sScript As String ' The complete script string +Dim oScriptProvider As Object ' Script provider singleton +Dim oScript As Object ' Return value + +Try: + ' Build script string + sScript = cstScript1 & psScript & cstScript2 & psLanguage & cstScript3 & LCase(psScope) + + ' Find script + Set oScript = Nothing + ' Python only: installation of extension is determined by user => unknown to script author + If psScope = SCRIPTISOXT Then ' => Trial and error + On Local Error GoTo ForAllUsers + sScript = cstScript1 & psScript & cstScript2 & psLanguage & cstScript3 & SCRIPTISPERSOXT + Set oScriptProvider = SF_Utils._GetUNOService("ScriptProvider", SCRIPTISPERSOXT) + Set oScript = oScriptProvider.getScript(sScript) + End If + ForAllUsers: + On Local Error GoTo CatchNotFound + If IsNull(oScript) Then + If psScope = SCRIPTISOXT Then psScope = SCRIPTISSHAROXT + Set oScriptProvider = SF_Utils._GetUNOService("ScriptProvider", psScope) + Set oScript = oScriptProvider.getScript(sScript) + End If + +Finally: + _GetScript = oScript + Exit Function +CatchNotFound: + SF_Exception.RaiseFatal(NOSCRIPTERROR, psLanguage, "Scope", psScope, "Script", psScript) + GoTo Finally +End Function ' ScriptForge.SF_Session._GetScript + +REM =============================================== END OF SCRIPTFORGE.SF_SESSION + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_String.xba b/wizards/source/scriptforge/SF_String.xba new file mode 100644 index 000000000..888cf672c --- /dev/null +++ b/wizards/source/scriptforge/SF_String.xba @@ -0,0 +1,2734 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_String +''' ========= +''' Singleton class implementing the "ScriptForge.String" service +''' Implemented as a usual Basic module +''' Focus on string manipulation, regular expressions, encodings and hashing algorithms +''' The first argument of almost every method is the string to consider +''' It is always passed by reference and left unchanged +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' Definitions +''' Line breaks: symbolic name(Ascii number) +''' LF(10), VT(12), CR(13), LF+CR, File separator(28), Group separator(29), Record separator(30), +''' Next Line(133), Line separator(8232), Paragraph separator(8233) +''' Whitespaces: symbolic name(Ascii number) +''' Space(32), HT(9), LF(10), VT(11), FF(12), CR(13), Next Line(133), No-break space(160), +''' Line separator(8232), Paragraph separator(8233) +''' A quoted string: +''' The quoting character must be the double quote (") +''' To preserve a quoting character inside the quoted substring, use (\) or (") as escape character +''' => [str\"i""ng] means [str"i"ng] +''' Escape sequences: symbolic name(Ascii number) = escape sequence +''' Line feed(10) = "\n" +''' Carriage return(13) = "\r" +''' Horizontal tab(9) = "\t" +''' Double the backslash to ignore the sequence, e.g. "\\n" means "\n" (not "\" & Chr(10)). +''' Not printable characters: +''' Defined in the Unicode character database as “Other” or “Separator” +''' In particular, "control" characters (ascii code <= 0x1F) are not printable +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_string.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' Some references: +''' https://api.libreoffice.org/docs/idl/ref/namespacecom_1_1sun_1_1star_1_1i18n_1_1KCharacterType.html +''' com.sun.star.i18n.KCharacterType.### +''' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1i18n_1_1XCharacterClassification.html +''' com.sun.star.i18n.XCharacterClassification + +REM ============================================================ MODULE CONSTANTS + +''' Most expressions below are derived from https://www.regular-expressions.info/ + +Const REGEXALPHA = "^[A-Za-z]+$" ' Not used +Const REGEXALPHANUM = "^[\w]+$" +Const REGEXDATEDAY = "(0[1-9]|[12][0-9]|3[01])" +Const REGEXDATEMONTH = "(0[1-9]|1[012])" +Const REGEXDATEYEAR = "(19|20)\d\d" +Const REGEXTIMEHOUR = "(0[1-9]|1[0-9]|2[0123])" +Const REGEXTIMEMIN = "([0-5][0-9])" +Const REGEXTIMESEC = REGEXTIMEMIN +Const REGEXDIGITS = "^[0-9]+$" +Const REGEXEMAIL = "^[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,}$" +Const REGEXFILELINUX = "^[^<>:;,?""*|\\]+$" +Const REGEXFILEWIN = "^([A-Z]|[a-z]:)?[^<>:;,?""*|]+$" +Const REGEXHEXA = "^(0X|&H)?[0-9A-F]+$" ' Includes 0xFF and &HFF +Const REGEXIPV4 = "^(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)$" +Const REGEXNUMBER = "^[-+]?(([0-9]+)?\.)?[0-9]+([eE][-+]?[0-9]+)?$" +Const REGEXURL = "^(https?|ftp)://[^\s/$.?#].[^\s]*$" +Const REGEXWHITESPACES = "^[\s]+$" +Const REGEXLTRIM = "^[\s]+" +Const REGEXRTRIM = "[\s]+$" +Const REGEXSPACES = "[\s]+" + +''' Accented characters substitution: https://docs.google.com/spreadsheets/d/1pJKSueZK8RkAcJFQIiKpYUamWSC1u1xVQchK7Z7BIwc/edit#gid=0 +''' (Many of them are in the list, but do not consider the list as closed vs. the Unicode database) + +Const cstCHARSWITHACCENT = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿŠšŸŽž" _ + & "ĂăĐđĨĩŨũƠơƯưẠạẢảẤấẦầẨẩẪẫẬậẮắẰằẲẳẴẵẶặẸẹẺẻẼẽẾếỀềỂểỄễỆệỈỉỊịỌọỎỏỐốỒồỔổỖỗỘộỚớỜờỞởỠỡỢợỤụỦủỨứỪừỬửỮữỰựỲỳỴỵỶỷỸỹ₫" +Const cstCHARSWITHOUTACCENT = "AAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyySsYZz" _ + & "AaDdIiUuOoUuAaAaAaAaAaAaAaAaAaAaAaAaEeEeEeEeEeEeEeEeIiIiOoOoOoOoOoOoOoOoOoOoOoOoUuUuUuUuUuUuUuYyYyYyYyd" + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_String Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CHARSWITHACCENT() As String +''' Latin accents + CHARSWITHACCENT = cstCHARSWITHACCENT +End Property ' ScriptForge.SF_String.CHARSWITHACCENT + +REM ----------------------------------------------------------------------------- +Property Get CHARSWITHOUTACCENT() As String +''' Latin accents + CHARSWITHOUTACCENT = cstCHARSWITHOUTACCENT +End Property ' ScriptForge.SF_String.CHARSWITHOUTACCENT + +''' Symbolic constants for linebreaks +REM ----------------------------------------------------------------------------- +Property Get sfCR() As Variant +''' Carriage return + sfCR = Chr(13) +End Property ' ScriptForge.SF_String.sfCR + +REM ----------------------------------------------------------------------------- +Property Get sfCRLF() As Variant +''' Carriage return + sfCRLF = Chr(13) & Chr(10) +End Property ' ScriptForge.SF_String.sfCRLF + +REM ----------------------------------------------------------------------------- +Property Get sfLF() As Variant +''' Linefeed + sfLF = Chr(10) +End Property ' ScriptForge.SF_String.sfLF + +REM ----------------------------------------------------------------------------- +Property Get sfNEWLINE() As Variant +''' Linefeed or Carriage return + Linefeed + sfNEWLINE = Iif(GetGuiType() = 1, Chr(13), "") & Chr(10) +End Property ' ScriptForge.SF_String.sfNEWLINE + +REM ----------------------------------------------------------------------------- +Property Get sfTAB() As Variant +''' Horizontal tabulation + sfTAB = Chr(9) +End Property ' ScriptForge.SF_String.sfTAB + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_String" +End Property ' ScriptForge.SF_String.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.String" +End Property ' ScriptForge.SF_String.ServiceName + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function Capitalize(Optional ByRef InputStr As Variant) As String +''' Return the input string with the 1st character of each word in title case +''' Args: +''' InputStr: the input string +''' Returns: +''' The input string with the 1st character of each word in title case +''' Examples: +''' SF_String.Capitalize("this is a title for jean-pierre") returns "This Is A Title For Jean-Pierre" + +Dim sCapital As String ' Return value +Dim lLength As Long ' Length of input string +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oChar As Object ' com.sun.star.i18n.CharacterClassification +Const cstThisSub = "String.Capitalize" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCapital = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + If lLength > 0 Then + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + Set oChar = SF_Utils._GetUNOService("CharacterClass") + sCapital = oChar.toTitle(InputStr, 0, lLength * 4, oLocale) ' length * 4 because length is expressed in bytes + End If + +Finally: + Capitalize = sCapital + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Capitalize + +REM ----------------------------------------------------------------------------- +Public Function Count(Optional ByRef InputStr As Variant _ + , Optional ByVal Substring As Variant _ + , Optional ByRef IsRegex As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Long +''' Counts the number of occurrences of a substring or a regular expression within a string +''' Args: +''' InputStr: the input stringto examine +''' Substring: the substring to identify +''' IsRegex: True if Substring is a regular expression (default = False) +''' CaseSensitive: default = False +''' Returns: +''' The number of occurrences as a Long +''' Examples: +''' SF_String.Count("Lorem ipsum dolor sit amet, consectetur adipiscing elit.", "\b[a-z]+\b", IsRegex := True, CaseSensitive := True) +''' returns 7 (the number of words in lower case) +''' SF_String.Count("Lorem ipsum dolor sit amet, consectetur adipiscing elit.", "or", CaseSensitive := False) +''' returns 2 + + +Dim lOccurrences As Long ' Return value +Dim lStart As Long ' Start index of search +Dim sSubstring As String ' Substring to replace +Dim iCaseSensitive As Integer ' Integer alias for boolean CaseSensitive +Const cstThisSub = "String.Count" +Const cstSubArgs = "InputStr, Substring, [IsRegex=False], [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + lOccurrences = 0 + +Check: + If IsMissing(IsRegex) Or IsEmpty(IsRegex) Then IsRegex = False + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Substring, "Substring", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(IsRegex, "IsRegex", V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + iCaseSensitive = Iif(CaseSensitive, 0, 1) ' 1 = False ;) + lStart = 1 + + Do While lStart >= 1 And lStart <= Len(InputStr) + Select Case IsRegex + Case False ' Use InStr + lStart = InStr(lStart, InputStr, Substring, iCaseSensitive) + If lStart = 0 Then Exit Do + lStart = lStart + Len(Substring) + Case True ' Use FindRegex + sSubstring = SF_String.FindRegex(InputStr, Substring, lStart, CaseSensitive) + If lStart = 0 Then Exit Do + lStart = lStart + Len(sSubstring) + End Select + lOccurrences = lOccurrences + 1 + Loop + +Finally: + Count = lOccurrences + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Count + +REM ----------------------------------------------------------------------------- +Public Function EndsWith(Optional ByRef InputStr As Variant _ + , Optional ByVal Substring As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Boolean +''' Returns True if the last characters of InputStr are identical to Substring +''' Args: +''' InputStr: the input string +''' Substring: the suffixing characters +''' CaseSensitive: default = False +''' Returns: +''' True if the comparison is satisfactory +''' False if either InputStr or Substring have a length = 0 +''' False if Substr is longer than InputStr +''' Examples: +''' SF_String.EndsWith("abcdefg", "EFG") returns True +''' SF_String.EndsWith("abcdefg", "EFG", CaseSensitive := True) returns False + +Dim bEndsWith As Boolean ' Return value +Dim lSub As Long ' Length of SUbstring +Const cstThisSub = "String.EndsWith" +Const cstSubArgs = "InputStr, Substring, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bEndsWith = False + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Substring, "Substring", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lSub = Len(Substring) + If Len(InputStr) > 0 And lSub > 0 And lSub <= Len(InputStr) Then + bEndsWith = ( StrComp(Right(InputStr, lSub), Substring, Iif(CaseSensitive, 1, 0)) = 0 ) + End If + +Finally: + EndsWith = bEndsWith + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.EndsWith + +REM ----------------------------------------------------------------------------- +Public Function Escape(Optional ByRef InputStr As Variant) As String +''' Convert any hard line breaks or tabs by their escaped equivalent +''' Args: +''' InputStr: the input string +''' Returns: +''' The input string after replacement of "\", Chr(10), Chr(13), Chr(9)characters +''' Examples: +''' SF_String.Escape("abc" & Chr(10) & Chr(9) & "def\n") returns "abc\n\tdef\\n" + +Dim sEscape As String ' Return value +Const cstThisSub = "String.Escape" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sEscape = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + sEscape = SF_String.ReplaceStr( InputStr _ + , Array("\", SF_String.sfLF, SF_String.sfCR, SF_String.sfTAB) _ + , Array("\\", "\n", "\r", "\t") _ + ) + +Finally: + Escape = sEscape + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Escape + +REM ----------------------------------------------------------------------------- +Public Function ExpandTabs(Optional ByRef InputStr As Variant _ + , Optional ByVal TabSize As Variant _ + ) As String +''' Return the input string with each TAB (Chr(9)) character replaced by the adequate number of spaces +''' Args: +''' InputStr: the input string +''' TabSize: defines the TAB positions at TabSize + 1, 2 * TabSize + 1 , ... N * TabSize + 1 +''' Default = 8 +''' Returns: +''' The input string with spaces replacing the TAB characters +''' If the input string contains line breaks, the TAB positions are reset +''' Examples: +''' SF_String.ExpandTabs("abc" & SF_String.sfTAB & SF_String.sfTAB & "def", 4) returns "abc def" +''' SF_String.ExpandTabs("abc" & SF_String.sfTAB & "def" & SF_String.sfLF & SF_String.sfTAB & "ghi") +''' returns "abc def" & SF_String.sfLF & " ghi" + +Dim sExpanded As String ' Return value +Dim lCharPosition As Long ' Position of current character in current line in expanded string +Dim lSpaces As Long ' Spaces counter +Dim sChar As String ' A single character +Dim i As Long +Const cstTabSize = 8 +Const cstThisSub = "String.ExpandTabs" +Const cstSubArgs = "InputStr, [TabSize=8]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sExpanded = "" + +Check: + If IsMissing(TabSize) Or IsEmpty(TabSize) Then TabSize = cstTabSize + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(TabSize, "TabSize", V_NUMERIC) Then GoTo Finally + End If + If TabSize <= 0 Then TabSize = cstTabSize + +Try: + lCharPosition = 0 + If Len(InputStr) > 0 Then + For i = 1 To Len(InputStr) + sChar = Mid(InputStr, i, 1) + Select Case sChar + Case SF_String.sfLF, Chr(12), SF_String.sfCR, Chr(28), Chr(29), Chr(30), Chr(133), Chr(8232), Chr(8233) + sExpanded = sExpanded & sChar + lCharPosition = 0 + Case SF_String.sfTAB + lSpaces = Int(lCharPosition / TabSize + 1) * TabSize - lCharPosition + sExpanded = sExpanded & Space(lSpaces) + lCharPosition = lCharPosition + lSpaces + Case Else + sExpanded = sExpanded & sChar + lCharPosition = lCharPosition + 1 + End Select + Next i + End If + +Finally: + ExpandTabs = sExpanded + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.ExpandTabs + +REM ----------------------------------------------------------------------------- +Public Function FilterNotPrintable(Optional ByRef InputStr As Variant _ + , Optional ByVal ReplacedBy As Variant _ + ) As String +''' Return the input string in which all the not printable characters are replaced by ReplacedBy +''' Among others, control characters (Ascii <= 1F) are not printable +''' Args: +''' InputStr: the input string +''' ReplacedBy: zero, one or more characters replacing the found not printable characters +''' Default = the zero-length string +''' Returns: +''' The input string in which all the not printable characters are replaced by ReplacedBy +''' Examples: +''' SF_String.FilterNotPrintable("àén ΣlPµ" & Chr(10) & " Русский", "\n") returns "àén ΣlPµ\n Русский" + +Dim sPrintable As String ' Return value +Dim bPrintable As Boolean ' Is a single character printable ? +Dim lLength As Long ' Length of InputStr +Dim lReplace As Long ' Length of ReplacedBy +Dim oChar As Object ' com.sun.star.i18n.CharacterClassification +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim lType As Long ' com.sun.star.i18n.KCharacterType +Dim sChar As String ' A single character +Dim lPRINTABLE As Long : lPRINTABLE = com.sun.star.i18n.KCharacterType.PRINTABLE +Dim i As Long +Const cstThisSub = "String.FilterNotPrintable" +Const cstSubArgs = "InputStr, [ReplacedBy=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sPrintable = "" + +Check: + If IsMissing(ReplacedBy) Or IsEmpty(ReplacedBy) Then ReplacedBy = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(ReplacedBy, "ReplacedBy", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + lReplace = Len(ReplacedBy) + If lLength > 0 Then + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + Set oChar = SF_Utils._GetUNOService("CharacterClass") + For i = 0 To lLength - 1 + sChar = Mid(InputStr, i + 1, 1) + lType = oChar.getCharacterType(sChar, 0, oLocale) + ' Parenthses (), [], {} have a KCharacterType = 0 + bPrintable = ( (lType And lPRINTABLE) = lPRINTABLE Or (lType = 0 And Asc(sChar) <= 127) ) + If Not bPrintable Then + If lReplace > 0 Then sPrintable = sPrintable & ReplacedBy + Else + sPrintable = sPrintable & sChar + End If + Next i + End If + +Finally: + FilterNotPrintable = sPrintable + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.FilterNotPrintable + +REM ----------------------------------------------------------------------------- +Public Function FindRegex(Optional ByRef InputStr As Variant _ + , Optional ByVal Regex As Variant _ + , Optional ByRef Start As Variant _ + , Optional ByVal CaseSensitive As Variant _ + , Optional ByVal Forward As Variant _ + ) As String +''' Find in InputStr a substring matching a given regular expression +''' Args: +''' InputStr: the input string to be searched for the expression +''' Regex: the regular expression +''' Start (passed by reference): where to start searching from +''' Should be = 1 (Forward = True) or = Len(InputStr) (Forward = False) the 1st time +''' After execution points to the first character of the found substring +''' CaseSensitive: default = False +''' Forward: True (default) or False (backward) +''' Returns: +''' The found substring matching the regular expression +''' A zero-length string if not found (Start is set to 0) +''' Examples: +''' Dim lStart As Long : lStart = 1 +''' SF_String.FindRegex("abCcdefghHij", "C.*H", lStart, CaseSensitive := True) returns "CcdefghH" +''' Above statement may be reexecuted for searching the same or another pattern +''' by starting from lStart + Len(matching string) + +Dim sOutput As String ' Return value +Dim oTextSearch As Object ' com.sun.star.util.TextSearch +Dim vOptions As Variant ' com.sun.star.util.SearchOptions +Dim lEnd As Long ' Upper limit of search area +Dim vResult As Object ' com.sun.star.util.SearchResult +Const cstThisSub = "String.FindRegex" +Const cstSubArgs = "InputStr, Regex, [Start=1], [CaseSensitive=False], [Forward=True]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sOutput = "" + +Check: + If IsMissing(Start) Or IsEmpty(Start) Then Start = 1 + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If IsMissing(Forward) Or IsEmpty(Forward) Then Forward = True + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Start, "Start", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Forward, "Forward", V_BOOLEAN) Then GoTo Finally + End If + If Start <= 0 Or Start > Len(InputStr) Then GoTo Finally + +Try: + sOutput = "" + Set oTextSearch = SF_Utils._GetUNOService("TextSearch") + ' Set pattern search options + vOptions = SF_Utils._GetUNOService("SearchOptions") + With vOptions + .searchString = Regex + If CaseSensitive Then .transliterateFlags = 0 Else .transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE + End With + ' Run search + With oTextSearch + .setOptions(vOptions) + If Forward Then + lEnd = Len(InputStr) + vResult = .searchForward(InputStr, Start - 1, lEnd) + Else + lEnd = 1 + vResult = .searchBackward(InputStr, Start, lEnd - 1) + End If + End With + ' https://api.libreoffice.org/docs/idl/ref/structcom_1_1sun_1_1star_1_1util_1_1SearchResult.html + With vResult + If .subRegExpressions >= 1 Then + If Forward Then + Start = .startOffset(0) + 1 + lEnd = .endOffset(0) + 1 + Else + Start = .endOffset(0) + 1 + lEnd = .startOffset(0) + 1 + End If + sOutput = Mid(InputStr, Start, lEnd - Start) + Else + Start = 0 + End If + End With + +Finally: + FindRegex = sOutput + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.FindRegex + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "String.GetProperty" +Const cstSubArgs = "PropertyName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case "SFCR" : GetProperty = sfCR + Case "SFCRLF" : GetProperty = sfCRLF + Case "SFLF" : GetProperty = sfLF + Case "SFNEWLINE" : GetProperty = sfNEWLINE + Case "SFTAB" : GetProperty = sfTAB + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function HashStr(Optional ByVal InputStr As Variant _ + , Optional ByVal Algorithm As Variant _ + ) As String +''' Return an hexadecimal string representing a checksum of the given input string +''' Next algorithms are supported: MD5, SHA1, SHA224, SHA256, SHA384 and SHA512 +''' Args: +''' InputStr: the string to be hashed +''' Algorithm: The hashing algorithm to use +''' Returns: +''' The requested checksum as a string. Hexadecimal digits are lower-cased +''' A zero-length string when an error occurred +''' Example: +''' Print SF_String.HashStr("œ∑¡™£¢∞§¶•ªº–≠œ∑´®†¥¨ˆøπ“‘åß∂ƒ©˙∆˚¬", "MD5") ' 616eb9c513ad07cd02924b4d285b9987 + +Dim sHash As String ' Return value +Const cstPyHelper = "$" & "_SF_String__HashStr" +Const cstThisSub = "String.HashStr" +Const cstSubArgs = "InputStr, Algorithm=""MD5""|""SHA1""|""SHA224""|""SHA256""|""SHA384""|""SHA512""" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sHash = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Algorithm, "Algorithm", V_STRING _ + , Array("MD5", "SHA1", "SHA224", "SHA256", "SHA384", "SHA512")) Then GoTo Finally + End If + +Try: + With ScriptForge.SF_Session + sHash = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper _ + , InputStr, LCase(Algorithm)) + End With + +Finally: + HashStr = sHash + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.HashStr + +REM ----------------------------------------------------------------------------- +Public Function HtmlEncode(Optional ByRef InputStr As Variant) As String +''' &-encoding of the input string (e.g. "é" becomes "&eacute;" or numeric equivalent +''' Args: +''' InputStr: the input string +''' Returns: +''' the encoded string +''' Examples: +''' SF_String.HtmlEncode("<a href=""https://a.b.com"">From α to ω</a>") +''' returns "&lt;a href=&quot;https://a.b.com&quot;&gt;From &#945; to &#969;&lt;/a&gt;" + +Dim sEncode As String ' Return value +Dim lPos As Long ' Position in InputStr +Dim sChar As String ' A single character extracted from InputStr +Dim i As Long +Const cstThisSub = "String.HtmlEncode" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sEncode = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then + lPos = 1 + sEncode = InputStr + Do While lPos <= Len(sEncode) + sChar = Mid(sEncode, lPos, 1) + ' Leave as is or encode every single char + Select Case sChar + Case """" : sChar = "&quot;" + Case "&" : sChar = "&amp;" + Case "<" : sChar = "&lt;" + Case ">" : sChar = "&gt;" + Case "'" : sChar = "&apos;" + Case ":", "/", "?", "#", "[", "]", "@" ' Reserved characters + Case SF_String.sfCR : sChar = "" ' Carriage return + Case SF_String.sfLF : sChar = "<br>" ' Line Feed + Case < Chr(126) + Case "€" : sChar = "&euro;" + Case Else : sChar = "&#" & Asc(sChar) & ";" + End Select + If Len(sChar) = 1 Then + Mid(sEncode, lPos, 1) = sChar + Else + sEncode = Left(sEncode, lPos - 1) & sChar & Mid(sEncode, lPos + 1) + End If + lPos = lPos + Len(sChar) + Loop + End If + +Finally: + HtmlEncode = sEncode + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.HtmlEncode + +REM ----------------------------------------------------------------------------- +Public Function IsADate(Optional ByRef InputStr As Variant _ + , Optional ByVal DateFormat _ + ) As Boolean +''' Return True if the string is a valid date respecting the given format +''' Args: +''' InputStr: the input string +''' DateFormat: either YYYY-MM-DD (default), DD-MM-YYYY or MM-DD-YYYY +''' The dash (-) may be replaced by a dot (.), a slash (/) or a space +''' Returns: +''' True if the string contains a valid date and there is at least one character +''' False otherwise or if the date format is invalid +''' Examples: +''' SF_String.IsADate("2019-12-31", "YYYY-MM-DD") returns True + +Dim bADate As Boolean ' Return value +Dim sFormat As String ' Alias for DateFormat +Dim iYear As Integer ' Alias of year in input string +Dim iMonth As Integer ' Alias of month in input string +Dim iDay As Integer ' Alias of day in input string +Dim dDate As Date ' Date value +Const cstFormat = "YYYY-MM-DD" ' Default date format +Const cstFormatRegex = "(YYYY[- /.]MM[- /.]DD|MM[- /.]DD[- /.]YYYY|DD[- /.]MM[- /.]YYYY)" + ' The regular expression the format must match +Const cstThisSub = "String.IsADate" +Const cstSubArgs = "InputStr, [DateFormat=""" & cstFormat & """]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bADate = False + +Check: + If IsMissing(DateFormat) Or IsEmpty(DateFormat) Then DateFormat = "YYYY-MM-DD" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(DateFormat, "DateFormat", V_STRING) Then GoTo Finally + End If + sFormat = UCase(DateFormat) + If Len(sFormat) <> Len(cstFormat)Then GoTo Finally + If sFormat <> cstFormat Then ' Do not check if default format + If Not SF_String.IsRegex(sFormat, cstFormatRegex) Then GoTo Finally + End If + +Try: + If Len(InputStr) = Len(DateFormat) Then + ' Extract the date components YYYY, MM, DD from the input string + iYear = CInt(Mid(InputStr, InStr(sFormat, "YYYY"), 4)) + iMonth = CInt(Mid(InputStr, InStr(sFormat, "MM"), 2)) + iDay = CInt(Mid(InputStr, InStr(sFormat, "DD"), 2)) + ' Check the validity of the date + On Local Error GoTo NotADate + dDate = DateSerial(iYear, iMonth, iDay) + bADate = True ' Statement reached only if no error + End If + +Finally: + IsADate = bADate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +NotADate: + On Error GoTo 0 ' Reset the error object + GoTo Finally +End Function ' ScriptForge.SF_String.IsADate + +REM ----------------------------------------------------------------------------- +Public Function IsAlpha(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are alphabetic +''' Alphabetic characters are those characters defined in the Unicode character database as “Letter” +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string is alphabetic and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsAlpha("àénΣlPµ") returns True +''' Note: +''' Use SF_String.IsRegex("...", REGEXALPHA) to limit characters to latin alphabet + +Dim bAlpha As Boolean ' Return value +Dim lLength As Long ' Length of InputStr +Dim oChar As Object ' com.sun.star.i18n.CharacterClassification +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim lType As Long ' com.sun.star.i18n.KCharacterType +Dim lLETTER As Long : lLETTER = com.sun.star.i18n.KCharacterType.LETTER +Dim i As Long +Const cstThisSub = "String.IsAlpha" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bAlpha = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + If lLength > 0 Then + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + Set oChar = SF_Utils._GetUNOService("CharacterClass") + For i = 0 To lLength - 1 + lType = oChar.getCharacterType(InputStr, i, oLocale) + bAlpha = ( (lType And lLETTER) = lLETTER ) + If Not bAlpha Then Exit For + Next i + End If + +Finally: + IsAlpha = bAlpha + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsAlpha + +REM ----------------------------------------------------------------------------- +Public Function IsAlphaNum(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are alphabetic, digits or "_" (underscore) +''' The first character must not be a digit +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string is alphanumeric and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsAlphaNum("_ABC_123456_abcàénΣlPµ") returns True + +Dim bAlphaNum As Boolean ' Return value +Dim sInputStr As String ' Alias of InputStr without underscores +Dim sFirst As String ' Leftmost character of InputStr +Dim lLength As Long ' Length of InputStr +Dim oChar As Object ' com.sun.star.i18n.CharacterClassification +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim lType As Long ' com.sun.star.i18n.KCharacterType +Dim lLETTER As Long : lLETTER = com.sun.star.i18n.KCharacterType.LETTER +Dim lDIGIT As Long : lDIGIT = com.sun.star.i18n.KCharacterType.DIGIT +Dim i As Long +Const cstThisSub = "String.IsAlphaNum" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bAlphaNum = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + If lLength > 0 Then + sFirst = Left(InputStr, 1) + bAlphanum = ( sFirst < "0" Or sFirst > "9" ) + If bAlphaNum Then + sInputStr = Replace(InputStr, "_", "A") ' Replace by an arbitrary alphabetic character + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + Set oChar = SF_Utils._GetUNOService("CharacterClass") + For i = 0 To lLength - 1 + lType = oChar.getCharacterType(sInputStr, i, oLocale) + bAlphaNum = ( (lType And lLETTER) = lLETTER _ + Or (lType And lDIGIT) = lDIGIT ) + If Not bAlphaNum Then Exit For + Next i + End If + End If + +Finally: + IsAlphaNum = bAlphaNum + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsAlphaNum + +REM ----------------------------------------------------------------------------- +Public Function IsAscii(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are Ascii characters +''' Ascii characters are those characters defined between &H00 and &H7F +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string is Ascii and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsAscii("a%?,25") returns True + +Dim bAscii As Boolean ' Return value +Dim lLength As Long ' Length of InputStr +Dim sChar As String ' Single character +Dim i As Long +Const cstThisSub = "String.IsAscii" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bAscii = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + If lLength > 0 Then + For i = 1 To lLength + sChar = Mid(InputStr, i, 1) + bAscii = ( Asc(sChar) <= 127 ) + If Not bAscii Then Exit For + Next i + End If + +Finally: + IsAscii = bAscii + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsAscii + +REM ----------------------------------------------------------------------------- +Public Function IsDigit(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are digits +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains only digits and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsDigit("123456") returns True + +Dim bDigit As Boolean ' Return value +Const cstThisSub = "String.IsDigit" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bDigit = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bDigit = SF_String.IsRegex(InputStr, REGEXDIGITS, CaseSensitive := False) + +Finally: + IsDigit = bDigit + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsDigit + +REM ----------------------------------------------------------------------------- +Public Function IsEmail(Optional ByRef InputStr As Variant) As Boolean +''' Return True if the string is a valid email address +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains an email address and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsEmail("first.last@something.org") returns True + +Dim bEmail As Boolean ' Return value +Const cstThisSub = "String.IsEmail" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bEmail = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bEmail = SF_String.IsRegex(InputStr, REGEXEMAIL, CaseSensitive := False) + +Finally: + IsEmail = bEmail + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsEmail + +REM ----------------------------------------------------------------------------- +Public Function IsFileName(Optional ByRef InputStr As Variant _ + , Optional ByVal OSName As Variant _ + ) As Boolean +''' Return True if the string is a valid filename in a given operating system +''' Args: +''' InputStr: the input string +''' OSName: Windows, Linux, macOS or Solaris +''' The default is the current operating system on which the script is run +''' Returns: +''' True if the string contains a valid filename and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsFileName("/home/a file name.odt", "LINUX") returns True + +Dim bFileName As Boolean ' Return value +Dim sRegex As String ' Regex to apply depending on OS +Const cstThisSub = "String.IsFileName" +Const cstSubArgs = "InputStr, [OSName=""Windows""|""Linux""|""macOS""|Solaris""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bFileName = False + +Check: + If IsMissing(OSName) Or IsEmpty(OSName) Then + If _SF_.OSname = "" Then _SF_.OSName = SF_Platform.OSName + OSName = _SF_.OSName + End If + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(OSName, "OSName", V_STRING, Array("Windows", "Linux", "macOS", "Solaris")) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then + Select Case UCase(OSName) + Case "LINUX", "MACOS", "SOLARIS" : sRegex = REGEXFILELINUX + Case "WINDOWS" : sRegex = REGEXFILEWIN + End Select + bFileName = SF_String.IsRegex(InputStr, sRegex, CaseSensitive := False) + End If + +Finally: + IsFileName = bFileName + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsFileName + +REM ----------------------------------------------------------------------------- +Public Function IsHexDigit(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are hexadecimal digits +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains only hexadecimal igits and there is at least one character +''' The prefixes "0x" and "&H" are admitted +''' False otherwise +''' Examples: +''' SF_String.IsHexDigit("&H00FF") returns True + +Dim bHexDigit As Boolean ' Return value +Const cstThisSub = "String.IsHexDigit" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bHexDigit = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bHexDigit = SF_String.IsRegex(InputStr, REGEXHEXA, CaseSensitive := False) + +Finally: + IsHexDigit = bHexDigit + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsHexDigit + +REM ----------------------------------------------------------------------------- +Public Function IsIBAN(Optional ByVal InputStr As Variant) As Boolean +''' Returns True if the input string is a valid International Bank Account Number +''' Read https://en.wikipedia.org/wiki/International_Bank_Account_Number +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains a valid IBAN number. The comparison is not case-sensitive +''' Examples: +''' SF_String.IsIBAN("BR15 0000 0000 0000 1093 2840 814 P2") returns True + +Dim bIBAN As Boolean ' Return value +Dim sIBAN As String ' Transformed input string +Dim sChar As String ' A single character +Dim sLetter As String ' Integer representation of letters +Dim iIndex As Integer ' Index in IBAN string +Dim sLong As String ' String representation of a Long +Dim iModulo97 As Integer ' Remainder of division by 97 +Dim i As Integer +Const cstThisSub = "String.IsIBAN" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bIBAN = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + sIBAN = "" + ' 1. Remove spaces. Check that the total IBAN length is correct as per the country. If not, the IBAN is invalid + ' NOT DONE: Country specific + sIBAN = Replace(InputStr, " ", "") + If Len(sIBAN) < 5 Or Len(sIBAN) > 34 Then GoTo Finally + + ' 2. Move the four initial characters to the end of the string. String is case-insensitive + sIBAN = UCase(Mid(sIBAN, 5) & Left(sIBAN, 4)) + + ' 3. Replace each letter in the string with two digits, thereby expanding the string, where A = 10, B = 11, ..., Z = 35 + iIndex = 1 + Do While iIndex < Len(sIBAN) + sChar = Mid(sIBAN, iIndex, 1) + If sChar >= "A" And sChar <= "Z" Then + sLetter = CStr(Asc(sChar) - Asc("A") + 10) + sIBAN = Left(sIBAN, iIndex - 1) & sLetter & Mid(sIBAN, iIndex + 1) + iIndex = iIndex + 2 + ElseIf sChar < "0" Or sChar > "9" Then ' Remove any non-alphanumeric character + GoTo Finally + Else + iIndex = iIndex + 1 + End If + Loop + + ' 4. Interpret the string as a decimal integer and compute the remainder of that number on division by 97 + ' Computation is done in chunks of 9 digits + iIndex = 3 + sLong = Left(sIBAN, 2) + Do While iIndex <= Len(sIBAN) + sLong = sLong & Mid(sIBAN, iIndex, 7) + iModulo97 = CLng(sLong) Mod 97 + iIndex = iIndex + Len(sLong) - 2 + sLong = Right("0" & CStr(iModulo97), 2) ' Force leading zero + Loop + + bIBAN = ( iModulo97 = 1 ) + +Finally: + IsIBAN = bIBAN + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsIBAN + +REM ----------------------------------------------------------------------------- +Public Function IsIPv4(Optional ByRef InputStr As Variant) As Boolean +''' Return True if the string is a valid IPv4 address +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains a valid IPv4 address and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsIPv4("192.168.1.50") returns True + +Dim bIPv4 As Boolean ' Return value +Const cstThisSub = "String.IsIPv4" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bIPv4 = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bIPv4 = SF_String.IsRegex(InputStr, REGEXIPV4, CaseSensitive := False) + +Finally: + IsIPv4 = bIPv4 + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsIPv4 + +REM ----------------------------------------------------------------------------- +Public Function IsLike(Optional ByRef InputStr As Variant _ + , Optional ByVal Pattern As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Boolean +''' Returns True if the whole input string matches a given pattern containing wildcards +''' Args: +''' InputStr: the input string +''' Pattern: the pattern as a string +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' CaseSensitive: default = False +''' Returns: +''' True if a match is found +''' Zero-length input or pattern strings always return False +''' Examples: +''' SF_String.IsLike("aAbB", "?A*") returns True +''' SF_String.IsLike("C:\a\b\c\f.odb", "?:*.*") returns True + +Dim bLike As Boolean ' Return value +' Build an equivalent regular expression by escaping the special characters present in Pattern +Dim sRegex As String ' Equivalent regular expression +Const cstSpecialChars = "\,^,$,.,|,+,(,),[,{,?,*" ' List of special chars in regular expressions +Const cstEscapedChars = "\\,\^,\$,\.,\|,\+,\(,\),\[,\{,.,.*" + +Const cstThisSub = "String.IsLike" +Const cstSubArgs = "InputStr, Pattern, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bLike = False + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Pattern, "Pattern", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 And Len(Pattern) > 0 Then + ' Substitute special chars by escaped chars + sRegex = SF_String.ReplaceStr(Pattern, Split(cstSPecialChars, ","), Split(cstEscapedChars, ",")) + bLike = SF_String.IsRegex(InputStr, sRegex, CaseSensitive) + End If + +Finally: + IsLike = bLike + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsLike + +REM ----------------------------------------------------------------------------- +Public Function IsLower(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are in lower case +''' Non alphabetic characters are ignored +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains only lower case characters and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsLower("abc'(-xyz") returns True + +Dim bLower As Boolean ' Return value +Const cstThisSub = "String.IsLower" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bLower = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bLower = ( StrComp(InputStr, LCase(InputStr), 1) = 0 ) + +Finally: + IsLower = bLower + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsLower + +REM ----------------------------------------------------------------------------- +Public Function IsPrintable(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are printable +''' In particular, control characters (Ascii <= 1F) are not printable +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string is printable and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsPrintable("àén ΣlPµ Русский") returns True + +Dim bPrintable As Boolean ' Return value +Dim lLength As Long ' Length of InputStr +Dim oChar As Object ' com.sun.star.i18n.CharacterClassification +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim lType As Long ' com.sun.star.i18n.KCharacterType +Dim sChar As String ' A single character +Dim lPRINTABLE As Long : lPRINTABLE = com.sun.star.i18n.KCharacterType.PRINTABLE +Dim i As Long +Const cstThisSub = "String.IsPrintable" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrintable = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + If lLength > 0 Then + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + Set oChar = SF_Utils._GetUNOService("CharacterClass") + For i = 0 To lLength - 1 + sChar = Mid(InputStr, i + 1, 1) + lType = oChar.getCharacterType(sChar, 0, oLocale) + ' Parenthses (), [], {} have a KCharacterType = 0 + bPrintable = ( (lType And lPRINTABLE) = lPRINTABLE Or (lType = 0 And Asc(sChar) <= 127) ) + If Not bPrintable Then Exit For + Next i + End If + +Finally: + IsPrintable = bPrintable + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsPrintable + +REM ----------------------------------------------------------------------------- +Public Function IsRegex(Optional ByRef InputStr As Variant _ + , Optional ByVal Regex As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Boolean +''' Returns True if the whole input string matches a given regular expression +''' Args: +''' InputStr: the input string +''' Regex: the regular expression as a string +''' CaseSensitive: default = False +''' Returns: +''' True if a match is found +''' Zero-length input or regex strings always return False +''' Examples: +''' SF_String.IsRegex("aAbB", "[A-Za-z]+") returns True + +Dim bRegex As Boolean ' Return value +Dim lStart As Long ' Must be 1 +Dim sMatch As String ' Matching string +Const cstBegin = "^" ' Beginning of line symbol +Const cstEnd = "$" ' End of line symbol +Const cstThisSub = "String.IsRegex" +Const cstSubArgs = "InputStr, Regex, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRegex = False + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 And Len(Regex) > 0 Then + ' Whole string must match Regex + lStart = 1 + If Left(Regex, 1) <> cstBegin Then Regex = cstBegin & Regex + If Right(Regex, 1) <> cstEnd Then Regex = Regex & cstEnd + sMatch = SF_String.FindRegex(InputStr, Regex, lStart, CaseSensitive) + ' Match ? + bRegex = ( lStart = 1 And Len(sMatch) = Len(InputStr) ) + End If + +Finally: + IsRegex = bRegex + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsRegex + +REM ----------------------------------------------------------------------------- +Public Function IsSheetName(Optional ByRef InputStr As Variant) As Boolean +''' Return True if the input string can serve as a valid Calc sheet name +''' The sheet name must not contain the characters [ ] * ? : / \ +''' or the character ' (apostrophe) as first or last character. + +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string is validated as a potential Calc sheet name, False otherwise +''' Examples: +''' SF_String.IsSheetName("1àbc + ""def""") returns True + +Dim bSheetName As Boolean ' Return value +Const cstThisSub = "String.IsSheetName" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSheetName = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then + If Left(InputStr, 1) = "'" Or Right(InputStr, 1) = "'" Then + ElseIf InStr(InputStr, "[") _ + + InStr(InputStr, "]") _ + + InStr(InputStr, "*") _ + + InStr(InputStr, "?") _ + + InStr(InputStr, ":") _ + + InStr(InputStr, "/") _ + + InStr(InputStr, "\") _ + = 0 Then + bSheetName = True + End If + End If + +Finally: + IsSheetName = bSheetName + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsSheetName + +REM ----------------------------------------------------------------------------- +Public Function IsTitle(Optional ByRef InputStr As Variant) As Boolean +''' Return True if the 1st character of every word is in upper case and the other characters are in lower case +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string is capitalized and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsTitle("This Is A Title For Jean-Pierre") returns True + +Dim bTitle As Boolean ' Return value +Const cstThisSub = "String.IsTitle" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bTitle = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bTitle = ( StrComp(InputStr, SF_String.Capitalize(InputStr), 1) = 0 ) + +Finally: + IsTitle = bTitle + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsTitle + +REM ----------------------------------------------------------------------------- +Public Function IsUpper(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are in upper case +''' Non alphabetic characters are ignored +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains only upper case characters and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsUpper("ABC'(-XYZ") returns True + +Dim bUpper As Boolean ' Return value +Const cstThisSub = "String.IsUpper" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bUpper = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bUpper = ( StrComp(InputStr, UCase(InputStr), 1) = 0 ) + +Finally: + IsUpper = bUpper + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsUpper + +REM ----------------------------------------------------------------------------- +Public Function IsUrl(Optional ByRef InputStr As Variant) As Boolean +''' Return True if the string is a valid absolute URL (Uniform Resource Locator) +''' The parsing is done by the ParseStrict method of the URLTransformer UNO service +''' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1util_1_1XURLTransformer.html +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains a URL and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsUrl("http://foo.bar/?q=Test%20URL-encoded%20stuff") returns True + +Dim bUrl As Boolean ' Return value +Const cstThisSub = "String.IsUrl" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bUrl = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bUrl = ( Len(SF_FileSystem._ParseUrl(InputStr).Main) > 0 ) + +Finally: + IsUrl = bUrl + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsUrl + +REM ----------------------------------------------------------------------------- +Public Function IsWhitespace(Optional ByRef InputStr As Variant) As Boolean +''' Return True if all characters in the string are whitespaces +''' Whitespaces include Space(32), HT(9), LF(10), VT(11), FF(12), CR(13), Next Line(133), No-break space(160), +''' Line separator(8232), Paragraph separator(8233) +''' Args: +''' InputStr: the input string +''' Returns: +''' True if the string contains only whitespaces and there is at least one character, False otherwise +''' Examples: +''' SF_String.IsWhitespace(" " & Chr(9) & Chr(10)) returns True + +Dim bWhitespace As Boolean ' Return value +Const cstThisSub = "String.IsWhitespace" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bWhitespace = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then bWhitespace = SF_String.IsRegex(InputStr, REGEXWHITESPACES, CaseSensitive := False) + +Finally: + IsWhitespace = bWhitespace + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.IsWhitespace + +REM ----------------------------------------------------------------------------- +Public Function JustifyCenter(Optional ByRef InputStr As Variant _ + , Optional ByVal Length As Variant _ + , Optional ByVal Padding As Variant _ + ) As String +''' Return the input string center justified +''' Args: +''' InputStr: the input string +''' Length: the resulting string length (default = length of input string) +''' Padding: the padding (single) character (default = the ascii space) +''' Returns: +''' The input string without its leading and trailing white spaces +''' completed left and right up to a total length of Length with the character Padding +''' If the input string is empty, the returned string is empty too +''' If the requested length is shorter than the center justified input string, +''' then the returned string is truncated +''' Examples: +''' SF_String.JustifyCenter(" ABCDE ", Padding := "x") returns "xxABCDEFxx" + +Dim sJustify As String ' Return value +Dim lLength As Long ' Length of input string +Dim lJustLength As Long ' Length of trimmed input string +Dim sPadding As String ' Series of Padding characters +Const cstThisSub = "String.JustifyCenter" +Const cstSubArgs = "InputStr, [length=Len(InputStr)], [Padding="" ""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sJustify = "" + +Check: + If IsMissing(Length) Or IsEmpty(Length) Then Length = 0 + If IsMissing(Padding) Or IsMissing(Padding) Then Padding = " " + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Length, "Length", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(Padding, "Padding", V_STRING) Then GoTo Finally + End If + If Len(Padding) = 0 Then Padding = " " Else Padding = Left(Padding, 1) + +Try: + lLength = Len(InputStr) + If Length = 0 Then Length = lLength + If lLength > 0 Then + sJustify = SF_String.TrimExt(InputStr) ' Trim left and right + lJustLength = Len(sJustify) + If lJustLength > Length Then + sJustify = Mid(sJustify, Int((lJustLength - Length) / 2) + 1, Length) + ElseIf lJustLength < Length Then + sPadding = String(Int((Length - lJustLength) / 2), Padding) + sJustify = sPadding & sJustify & sPadding + If Len(sJustify) < Length Then sJustify = sJustify & Padding ' One Padding char is lacking when lJustLength is odd + End If + End If + +Finally: + JustifyCenter = sJustify + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.JustifyCenter + +REM ----------------------------------------------------------------------------- +Public Function JustifyLeft(Optional ByRef InputStr As Variant _ + , Optional ByVal Length As Variant _ + , Optional ByVal Padding As Variant _ + ) As String +''' Return the input string left justified +''' Args: +''' InputStr: the input string +''' Length: the resulting string length (default = length of input string) +''' Padding: the padding (single) character (default = the ascii space) +''' Returns: +''' The input string without its leading white spaces +''' filled up to a total length of Length with the character Padding +''' If the input string is empty, the returned string is empty too +''' If the requested length is shorter than the left justified input string, +''' then the returned string is truncated +''' Examples: +''' SF_String.JustifyLeft(" ABCDE ", Padding := "x") returns "ABCDE xxx" + +Dim sJustify As String ' Return value +Dim lLength As Long ' Length of input string +Const cstThisSub = "String.JustifyLeft" +Const cstSubArgs = "InputStr, [length=Len(InputStr)], [Padding="" ""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sJustify = "" + +Check: + If IsMissing(Length) Or IsEmpty(Length) Then Length = 0 + If IsMissing(Padding) Or IsMissing(Padding) Then Padding = " " + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Length, "Length", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(Padding, "Padding", V_STRING) Then GoTo Finally + End If + If Len(Padding) = 0 Then Padding = " " Else Padding = Left(Padding, 1) + +Try: + lLength = Len(InputStr) + If Length = 0 Then Length = lLength + If lLength > 0 Then + sJustify = SF_String.ReplaceRegex(InputStr, REGEXLTRIM, "") ' Trim left + If Len(sJustify) >= Length Then + sJustify = Left(sJustify, Length) + Else + sJustify = sJustify & String(Length - Len(sJustify), Padding) + End If + End If + +Finally: + JustifyLeft = sJustify + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.JustifyLeft + +REM ----------------------------------------------------------------------------- +Public Function JustifyRight(Optional ByRef InputStr As Variant _ + , Optional ByVal Length As Variant _ + , Optional ByVal Padding As Variant _ + ) As String +''' Return the input string right justified +''' Args: +''' InputStr: the input string +''' Length: the resulting string length (default = length of input string) +''' Padding: the padding (single) character (default = the ascii space) +''' Returns: +''' The input string without its trailing white spaces +''' preceded up to a total length of Length with the character Padding +''' If the input string is empty, the returned string is empty too +''' If the requested length is shorter than the right justified input string, +''' then the returned string is right-truncated +''' Examples: +''' SF_String.JustifyRight(" ABCDE ", Padding := "x") returns "x ABCDE" + +Dim sJustify As String ' Return value +Dim lLength As Long ' Length of input string +Const cstThisSub = "String.JustifyRight" +Const cstSubArgs = "InputStr, [length=Len(InputStr)], [Padding="" ""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sJustify = "" + +Check: + If IsMissing(Length) Or IsEmpty(Length) Then Length = 0 + If IsMissing(Padding) Or IsMissing(Padding) Then Padding = " " + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Length, "Length", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(Padding, "Padding", V_STRING) Then GoTo Finally + End If + If Len(Padding) = 0 Then Padding = " " Else Padding = Left(Padding, 1) + +Try: + lLength = Len(InputStr) + If Length = 0 Then Length = lLength + If lLength > 0 Then + sJustify = SF_String.ReplaceRegex(InputStr, REGEXRTRIM, "") ' Trim right + If Len(sJustify) >= Length Then + sJustify = Right(sJustify, Length) + Else + sJustify = String(Length - Len(sJustify), Padding) & sJustify + End If + End If + +Finally: + JustifyRight = sJustify + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.JustifyRight + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the String service as an array + + Methods = Array( _ + "Capitalize" _ + , "Count" _ + , "EndWith" _ + , "Escape" _ + , "ExpandTabs" _ + , "FilterNotPrintable" _ + , "FindRegex" _ + , "HashStr" _ + , "HtmlEncode" _ + , "IsADate" _ + , "IsAlpha" _ + , "IsAlphaNum" _ + , "IsAscii" _ + , "IsDigit" _ + , "IsEmail" _ + , "IsFileName" _ + , "IsHexDigit" _ + , "IsIPv4" _ + , "IsLike" _ + , "IsLower" _ + , "IsPrintable" _ + , "IsRegex" _ + , "IsSheetName" _ + , "IsTitle" _ + , "IsUpper" _ + , "IsUrl" _ + , "IsWhitespace" _ + , "JustifyCenter" _ + , "JustifyLeft" _ + , "JustifyRight" _ + , "Quote" _ + , "ReplaceChar" _ + , "ReplaceRegex" _ + , "ReplaceStr" _ + , "Represent" _ + , "Reverse" _ + , "SplitLines" _ + , "SplitNotQuoted" _ + , "StartsWith" _ + , "TrimExt" _ + , "Unescape" _ + , "Unquote" _ + , "Wrap" _ + ) + +End Function ' ScriptForge.SF_String.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties as an array + + Properties = Array( _ + "sfCR" _ + , "sfCRLF" _ + , "sfLF" _ + , "sfNEWLINE" _ + , "sfTAB" _ + ) + +End Function ' ScriptForge.SF_Session.Properties + +REM ----------------------------------------------------------------------------- +Public Function Quote(Optional ByRef InputStr As Variant _ + , Optional ByVal QuoteChar As String _ + ) As String +''' Return the input string surrounded with double quotes +''' Used f.i. to prepare a string field to be stored in a csv-like file +''' Args: +''' InputStr: the input string +''' QuoteChar: either " (default) or ' +''' Returns: +''' Existing - including leading and/or trailing - double quotes are doubled +''' Examples: +''' SF_String.Quote("àé""n ΣlPµ Русский") returns """àé""""n ΣlPµ Русский""" + +Dim sQuote As String ' Return value +Const cstDouble = """" : Const cstSingle = "'" +Const cstEscape = "\" +Const cstThisSub = "String.Quote" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sQuote = "" + +Check: + If IsMissing(QuoteChar) Or IsEmpty(QuoteChar) Then QuoteChar = cstDouble + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(QuoteChar, "QuoteChar", V_STRING, Array(cstDouble, cstSingle)) Then GoTo Finally + End If + +Try: + If QuoteChar = cstDouble Then + sQuote = cstDouble & Replace(InputStr, cstDouble, cstDouble & cstDouble) & cstDouble + Else + sQuote = Replace(InputStr, cstEscape, cstEscape & cstEscape) + sQuote = cstSingle & Replace(sQuote, cstSingle, cstEscape & cstSingle) & cstSingle + End If + +Finally: + Quote = sQuote + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Quote + +REM ----------------------------------------------------------------------------- +Public Function ReplaceChar(Optional ByRef InputStr As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal After As Variant _ + ) As String +''' Replace in InputStr all occurrences of any character from Before +''' by the corresponding character in After +''' Args: +''' InputStr: the input string on which replacements should occur +''' Before: a string of characters to replace 1 by 1 in InputStr +''' After: the replacing characters +''' Returns: +''' The new string after replacement of Nth character of Before by the Nth character of After +''' Replacements are done one by one => potential overlaps +''' If the length of Before is larger than the length of After, +''' the residual characters of Before are replaced by the last character of After +''' The input string when Before is the zero-length string +''' Examples: easily remove accents +''' SF_String.ReplaceChar("Protégez votre vie privée", "àâãçèéêëîïôöûüýÿ", "aaaceeeeiioouuyy") +''' returns "Protegez votre vie privee" +''' SF_String.ReplaceChar("Protégez votre vie privée", SF_String.CHARSWITHACCENT, SF_String.CHARSWITHOUTACCENT) + +Dim sOutput As String ' Return value +Dim iCaseSensitive As Integer ' Always 0 (True) +Dim sBefore As String ' A single character extracted from InputStr +Dim sAfter As String ' A single character extracted from After +Dim lInStr As Long ' Output of InStr() +Dim i As Long +Const cstThisSub = "String.ReplaceChar" +Const cstSubArgs = "InputStr, Before, After" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sOutput = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Before, "Before", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(After, "After", V_STRING) Then GoTo Finally + End If + +Try: + ' Replace standard function => Replace(string, before, after, start, occurrences, casesensitive) + sOutput = InputStr + iCaseSensitive = 0 + + ' Replace one by one up length of Before and After + If Len(Before) > 0 Then + i = 1 + Do While i <= Len(sOutput) + sBefore = Mid(sOutput, i, 1) + lInStr = InStr(1, Before, sBefore, iCaseSensitive) + If lInStr > 0 Then + If Len(After) = 0 Then + sAfter = "" + ElseIf lInStr > Len(After) Then + sAfter = Right(After, 1) + Else + sAfter = Mid(After, lInStr, 1) + End If + sOutput = Left(sOutput, i - 1) & Replace(sOutput, sBefore, sAfter, i, Empty, iCaseSensitive) + End If + i = i + 1 + Loop + End If + +Finally: + ReplaceChar = sOutput + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.ReplaceChar + +REM ----------------------------------------------------------------------------- +Public Function ReplaceRegex(Optional ByRef InputStr As Variant _ + , Optional ByVal Regex As Variant _ + , Optional ByRef NewStr As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As String +''' Replace in InputStr all occurrences of a given regular expression by NewStr +''' Args: +''' InputStr: the input string where replacements should occur +''' Regex: the regular expression +''' NewStr: the replacing string +''' CaseSensitive: default = False +''' Returns: +''' The new string after all replacements +''' Examples: +''' SF_String.ReplaceRegex("Lorem ipsum dolor sit amet, consectetur adipiscing elit.", "[a-z]", "x", CaseSensitive := True) +''' returns "Lxxxx xxxxx xxxxx xxx xxxx, xxxxxxxxxxx xxxxxxxxxx xxxx." +''' SF_String.ReplaceRegex("Lorem ipsum dolor sit amet, consectetur adipiscing elit.", "\b[a-z]+\b", "x", CaseSensitive := False) +''' returns "x x x x x, x x x." (each word is replaced by x) + + +Dim sOutput As String ' Return value +Dim lStartOld As Long ' Previous start of search +Dim lStartNew As Long ' Next start of search +Dim sSubstring As String ' Substring to replace +Const cstThisSub = "String.ReplaceRegex" +Const cstSubArgs = "InputStr, Regex, NewStr, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sOutput = "" + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(NewStr, "NewStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + sOutput = "" + lStartNew = 1 + lStartOld = 1 + + Do While lStartNew >= 1 And lStartNew <= Len(InputStr) + sSubstring = SF_String.FindRegex(InputStr, Regex, lStartNew, CaseSensitive) + If lStartNew = 0 Then ' Regex not found + ' Copy remaining substring of InputStr before leaving + sOutput = sOutput & Mid(InputStr, lStartOld) + Exit Do + End If + ' Append the interval between 2 occurrences and the replacing string + If lStartNew > lStartOld Then sOutput = sOutput & Mid(InputStr, lStartOld, lStartNew - lStartOld) + sOutput = sOutput & NewStr + lStartOld = lStartNew + Len(sSubstring) + lStartNew = lStartOld + Loop + +Finally: + ReplaceRegex = sOutput + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.ReplaceRegex + +REM ----------------------------------------------------------------------------- +Public Function ReplaceStr(Optional ByRef InputStr As Variant _ + , Optional ByVal OldStr As Variant _ + , Optional ByVal NewStr As Variant _ + , Optional ByVal Occurrences As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As String +''' Replace in InputStr some or all occurrences of OldStr by NewStr +''' Args: +''' InputStr: the input string on which replacements should occur +''' OldStr: the string to replace or a 1D array of strings to replace +''' Zero-length strings are ignored +''' NewStr: the replacing string or a 1D array of replacing strings +''' If OldStr is an array +''' each occurrence of any of the items of OldStr is replaced by NewStr +''' If OldStr and NewStr are arrays +''' replacements occur one by one up to the UBound of NewStr +''' remaining OldStr(ings) are replaced by the last element of NewStr +''' Occurrences: the maximum number of replacements (0, default, = all occurrences) +''' Is applied for each single replacement when OldStr is an array +''' CaseSensitive: True or False (default) +''' Returns: +''' The new string after replacements +''' Replacements are done one by one when OldStr is an array => potential overlaps +''' Examples: +''' SF_String.ReplaceStr("abCcdefghHij", Array("c", "h"), Array("Y", "Z"), CaseSensitive := False) returns "abYYdefgZZij" + +Dim sOutput As String ' Return value +Dim iCaseSensitive As Integer ' Integer alias for boolean CaseSensitive +Dim vOccurrences As Variant ' Variant alias for Integer Occurrences +Dim sNewStr As String ' Alias for a NewStr item +Dim i As Long, j As Long +Const cstThisSub = "String.ReplaceStr" +Const cstSubArgs = "InputStr, OldStr, NewStr, [Occurrences=0], [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sOutput = "" + +Check: + If IsMissing(Occurrences) Or IsEmpty(Occurrences) Then Occurrences = 0 + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If IsArray(OldStr) Then + If Not SF_Utils._ValidateArray(OldStr, "OldStr", 1, V_STRING, True) Then GoTo Finally + Else + If Not SF_Utils._Validate(OldStr, "OldStr", V_STRING) Then GoTo Finally + End If + If IsArray(NewStr) Then + If Not SF_Utils._ValidateArray(NewStr, "NewStr", 1, V_STRING, True) Then GoTo Finally + Else + If Not SF_Utils._Validate(NewStr, "NewStr", V_STRING) Then GoTo Finally + End If + If Not SF_Utils._Validate(Occurrences, "Occurrences", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + ' Replace standard function => Replace(string, before, after, start, occurrences, casesensitive) + sOutput = InputStr + iCaseSensitive = Iif(CaseSensitive, 0, 1) ' 1 = False ;) + vOccurrences = Iif(Occurrences = 0, Empty, Occurrences) ' Empty = no limit + If Not IsArray(OldStr) Then OldStr = Array(OldStr) + If Not IsArray(NewStr) Then NewStr = Array(NewStr) + + ' Replace one by one up to UBounds of Old and NewStr + j = LBound(NewStr) - 1 + For i = LBound(OldStr) To UBound(OldStr) + j = j + 1 + If j <= UBound(NewStr) Then sNewStr = NewStr(j) ' Else do not change + If StrComp(OldStr(i), sNewStr, 1) <> 0 Then + sOutput = Replace(sOutput, OldStr(i), sNewStr, 1, vOccurrences, iCaseSensitive) + End If + Next i + +Finally: + ReplaceStr = sOutput + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.ReplaceStr + +REM ----------------------------------------------------------------------------- +Public Function Represent(Optional ByRef AnyValue As Variant _ + , Optional ByVal MaxLength As Variant _ + ) As String +''' Return a readable (string) form of the argument, truncated at MaxLength +''' Args: +''' AnyValue: really any value (object, date, whatever) +''' MaxLength: the maximum length of the resulting string (Default = 0, unlimited) +''' Returns: +''' The argument converted or transformed into a string of a maximum length = MaxLength +''' Objects are surrounded with square brackets ([]) +''' In strings, tabs and line breaks are replaced by \t, \n or \r +''' If the effective length exceeds MaxLength, the final part of the string is replaced by " ... (N)" +''' where N = the total length of the string before truncation +''' Examples: +''' SF_String.Represent("this is a usual string") returns "this is a usual string" +''' SF_String.Represent("this is a usual string", 15) returns "this i ... (22)" +''' SF_String.Represent("this is a" & Chr(10) & " 2-lines string") returns "this is a\n 2-lines string" +''' SF_String.Represent(Empty) returns "[EMPTY]" +''' SF_String.Represent(Null) returns "[NULL]" +''' SF_String.Represent(Pi) returns "3.142" +''' SF_String.Represent(CreateUnoService("com.sun.star.util.PathSettings")) returns "[com.sun.star.comp.framework.PathSettings]" +''' SF_String.Represent(Array(1, 2, "Text" & Chr(9) & "here")) returns "[ARRAY] (0:2) (1, 2, Text\there)" +''' Dim myDict As Variant : myDict = CreateScriptService("Dictionary") +''' myDict.Add("A", 1) : myDict.Add("B", 2) +''' SF_String.Represent(myDict) returns "[Dictionary] ("A":1, "B":2)" + +Dim sRepr As String ' Return value +Const cstThisSub = "String.Represent" +Const cstSubArgs = "AnyValue, [MaxLength=0]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sRepr = "" + +Check: + If IsMissing(AnyValue) Then AnyValue = Empty + If IsMissing(MaxLength) Or IsEmpty(MaxLength) Then MaxLength = 0 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(MaxLength, "MaxLength", V_NUMERIC) Then GoTo Finally + End If + +Try: + sRepr = SF_Utils._Repr(AnyValue, MaxLength) + If MaxLength > 0 And MaxLength < Len(sRepr) Then sRepr = sRepr & " ... (" & Len(sRepr) & ")" + +Finally: + Represent = sRepr + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Represent + +REM ----------------------------------------------------------------------------- +Public Function Reverse(Optional ByRef InputStr As Variant) As String +''' Return the input string in reversed order +''' It is equivalent to the standard StrReverse Basic function +''' The latter requires the OpTion VBASupport 1 statement to be present in the module +''' Args: +''' InputStr: the input string +''' Returns: +''' The input string in reversed order +''' Examples: +''' SF_String.Reverse("abcdefghij") returns "jihgfedcba" + +Dim sReversed As String ' Return value +Dim lLength As Long ' Length of input string +Dim i As Long +Const cstThisSub = "String.Reverse" +Const cstSubArgs = "InputSt" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sReversed = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + lLength = Len(InputStr) + If lLength > 0 Then + sReversed = Space(lLength) + For i = 1 To lLength + Mid(sReversed, i, 1) = Mid(InputStr, lLength - i + 1) + Next i + End If + +Finally: + Reverse = sReversed + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Reverse + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "String.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SplitLines(Optional ByRef InputStr As Variant _ + , Optional ByVal KeepBreaks As Variant _ + ) As Variant +''' Return an array of the lines in a string, breaking at line boundaries +''' Line boundaries include LF(10), VT(12), CR(13), LF+CR, File separator(28), Group separator(29), Record separator(30), +''' Next Line(133), Line separator(8232), Paragraph separator(8233) +''' Args: +''' InputStr: the input string +''' KeepBreaks: when True, line breaks are preserved in the output array (default = False) +''' Returns: +''' An array of all the individual lines +''' Examples: +''' SF_String.SplitLines("Line1" & Chr(10) & "Line2" & Chr(13) & "Line3") returns ("Line1", "Line2", "Line3") +''' SF_String.SplitLines("Line1" & Chr(10) & "Line2" & Chr(13) & "Line3" & Chr(10)) returns ("Line1", "Line2", "Line3", "") + +Dim vSplit As Variant ' Return value +Dim vLineBreaks As Variant ' Array of recognized line breaks +Dim vTokenizedBreaks As Variant ' Array of line breaks extended with tokens +Dim sAlias As String ' Alias for input string +' The procedure uses (dirty) placeholders to identify line breaks +' The used tokens are presumed unlikely present in text strings +Dim sTokenCRLF As String ' Token to identify combined CR + LF +Dim sToken As String ' Token to identify any line break +Dim i As Long +Const cstThisSub = "String.SplitLines" +Const cstSubArgs = "InputStr, [KeepBreaks=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSplit = Array() + +Check: + If IsMissing(KeepBreaks) Or IsEmpty(KeepBreaks) Then KeepBreaks = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(KeepBreaks, "KeepBreaks", V_BOOLEAN) Then GoTo Finally + End If + +Try: + ' In next list CR + LF must precede CR and LF + vLineBreaks = Array(SF_String.sfCRLF, SF_String.sfLF, Chr(12), SF_String.sfCR _ + , Chr(28), Chr(29), Chr(30), Chr(133), Chr(8232), Chr(8233)) + + If KeepBreaks = False Then + ' Replace line breaks by linefeeds and split on linefeeds + vSplit = Split(SF_String.ReplaceStr(InputStr, vLineBreaks, SF_String.sfLF, CaseSensitive := False), SF_String.sfLF) + Else + sTokenCRLF = Chr(1) & "$" & Chr(2) & "*" & Chr(3) & "$" & Chr(1) + sToken = Chr(1) & "$" & Chr(2) & "*" & Chr(3) & "$" & Chr(2) + vTokenizedBreaks = Array() : ReDim vTokenizedBreaks(0 To UBound(vLineBreaks)) + ' Extend breaks with token + For i = 0 To UBound(vLineBreaks) + vTokenizedBreaks(i) = Iif(i = 0, sTokenCRLF, vLineBreaks(i)) & sToken + Next i + sAlias = SF_String.ReplaceStr(InputStr, vLineBreaks, vTokenizedBreaks, CaseSensitive := False) + ' Suppress CRLF tokens and split + vSplit = Split(Replace(sAlias, sTokenCRLF, SF_String.sfCRLF), sToken) + End If + +Finally: + SplitLines = vSplit + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.SplitLines + +REM ----------------------------------------------------------------------------- +Public Function SplitNotQuoted(Optional ByRef InputStr As Variant _ + , Optional ByVal Delimiter As Variant _ + , Optional ByVal Occurrences As Variant _ + , Optional ByVal QuoteChar As Variant _ + ) As Variant +''' Split a string on Delimiter into an array. If Delimiter is part of a quoted (sub)string, it is ignored +''' (used f.i. for parsing of csv-like records) +''' Args: +''' InputStr: the input string +''' Might contain quoted substrings: +''' The quoting character must be the double quote (") +''' To preserve a quoting character inside the quoted substring, use (\) or (") as escape character +''' => [str\"i""ng] means [str"i"ng] +''' Delimiter: A string of one or more characters that is used to delimit the input string +''' The default is the space character +''' Occurrences: The number of substrings to return (Default = 0, meaning no limit) +''' QuoteChar: The quoting character, either " (default) or ' +''' Returns: +''' An array whose items are chunks of the input string, Delimiter not included +''' Examples: +''' SF_String.SplitNotQuoted("abc def ghi") returns ("abc", "def", "ghi") +''' SF_String.SplitNotQuoted("abc,""def,ghi""", ",") returns ("abc", """def,ghi""") +''' SF_String.SplitNotQuoted("abc,""def\"",ghi""", ",") returns ("abc", """def\"",ghi""") +''' SF_String.SplitNotQuoted("abc,""def\"",ghi"""",", ",") returns ("abc", """def\"",ghi""", "") + +Dim vSplit As Variant ' Return value +Dim lDelimLen As Long ' Length of Delimiter +Dim vStart As Variant ' Array of start positions of quoted strings +Dim vEnd As Variant ' Array of end positions of quoted strings +Dim lInStr As Long ' InStr() on input string +Dim lInStrPrev As Long ' Previous value of lInputStr +Dim lBound As Long ' UBound of vStart and vEnd +Dim lMin As Long ' Lower bound to consider when searching vStart and vEnd +Dim oCharacterClass As Object ' com.sun.star.i18n.CharacterClassification +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oParse As Object ' com.sun.star.i18n.ParseResult +Dim sChunk As String ' Substring of InputStr +Dim bSplit As Boolean ' New chunk found or not +Dim i As Long +Const cstDouble = """" : Const cstSingle = "'" +Const cstThisSub = "String.SplitNotQuoted" +Const cstSubArgs = "InputStr, [Delimiter="" ""], [Occurrences=0], [QuoteChar=""" & cstDouble & """]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vSplit = Array() + +Check: + If IsMissing(Delimiter) Or IsEmpty(Delimiter) Then Delimiter = " " + If IsMissing(Occurrences) Or IsEmpty(Occurrences) Then Occurrences = 0 + If IsMissing(QuoteChar) Or IsEmpty(QuoteChar) Then QuoteChar = cstDouble + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Delimiter, "Delimiter", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Occurrences, "Occurrences", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(QuoteChar, "QuoteChar", V_STRING, Array(cstDouble, cstSingle)) Then GoTo Finally + End If + If Len(Delimiter) = 0 Then Delimiter = " " + +Try: + If Occurrences = 1 Or InStr(1, InputStr, Delimiter, 0) = 0 Then ' No reason to split + vSplit = Array(InputStr) + ElseIf InStr(1, InputStr, QuoteChar, 0) = 0 Then ' No reason to make a complex split + If Occurrences > 0 Then vSplit = Split(InputStr, Delimiter, Occurrences) Else vSplit = Split(InputStr, Delimiter) + Else + If Occurrences < 0 Then Occurrences = 0 + Set oCharacterClass = SF_Utils._GetUNOService("CharacterClass") + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + + ' Build an array of start/end positions of quoted strings containing at least 1x the Delimiter + vStart = Array() : vEnd = Array() + lInStr = InStr(1, InputStr, QuoteChar) + Do While lInStr > 0 + lBound = UBound(vStart) + ' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1i18n_1_1XCharacterClassification.html#ad5f1be91fbe86853200391f828d4166b + Set oParse = oCharacterClass.parsePredefinedToken( _ + Iif(QuoteChar = cstDouble, com.sun.star.i18n.KParseType.DOUBLE_QUOTE_STRING, com.sun.star.i18n.KParseType.SINGLE_QUOTE_NAME) _ + , InputStr, lInStr - 1, oLocale, 0, "", 0, "") + If oParse.CharLen > 0 Then ' Is parsing successful ? + ' Is there some delimiter ? + If InStr(1, oParse.DequotedNameOrString, Delimiter, 0) > 0 Then + vStart = SF_Array.Append(vStart, lInStr + 0) + vEnd = SF_Array.Append(vEnd, lInStr + oParse.CharLen - 1) + End If + lInStr = InStr(lInStr + oParse.CharLen, InputStr, QuoteChar) + Else + lInStr = 0 + End If + Loop + + lBound = UBound(vStart) + lDelimLen = Len(Delimiter) + If lBound < 0 Then ' Usual split is applicable + vSplit = Split(InputStr, Delimiter, Occurrences) + Else + ' Split chunk by chunk + lMin = 0 + lInStrPrev = 0 + lInStr = InStr(1, InputStr, Delimiter, 0) + Do While lInStr > 0 + If Occurrences > 0 And Occurrences = UBound(vSplit) - 1 Then Exit Do + bSplit = False + ' Ignore found Delimiter if in quoted string + For i = lMin To lBound + If lInStr < vStart(i) Then + bSplit = True + Exit For + ElseIf lInStr > vStart(i) And lInStr < vEnd (i) Then + Exit For + Else + lMin = i + 1 + If i = lBound Then bSplit = True Else bSplit = ( lInStr < vStart(lMin) ) + End If + Next i + ' Build next chunk and store in split array + If bSplit Then + If lInStrPrev = 0 Then ' First chunk + sChunk = Left(InputStr, lInStr - 1) + Else + sChunk = Mid(InputStr, lInStrPrev + lDelimLen, lInStr - lInStrPrev - lDelimLen) + End If + vSplit = SF_Array.Append(vSplit, sChunk & "") + lInStrPrev = lInStr + End If + lInStr = InStr(lInStr + lDelimLen, InputStr, Delimiter, 0) + Loop + If Occurrences = 0 Or Occurrences > UBound(vSplit) + 1 Then + sChunk = Mid(InputStr, lInStrPrev + lDelimLen) ' Append last chunk + vSplit = SF_Array.Append(vSplit, sChunk & "") + End If + End If + End If + +Finally: + SplitNotQuoted = vSplit + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.SplitNotQuoted + +REM ----------------------------------------------------------------------------- +Public Function StartsWith(Optional ByRef InputStr As Variant _ + , Optional ByVal Substring As Variant _ + , Optional ByVal CaseSensitive As Variant _ + ) As Boolean +''' Returns True if the first characters of InputStr are identical to Substring +''' Args: +''' InputStr: the input string +''' Substring: the prefixing characters +''' CaseSensitive: default = False +''' Returns: +''' True if the comparison is satisfactory +''' False if either InputStr or Substring have a length = 0 +''' False if Substr is longer than InputStr +''' Examples: +''' SF_String.StartsWith("abcdefg", "ABC") returns True +''' SF_String.StartsWith("abcdefg", "ABC", CaseSensitive := True) returns False + +Dim bStartsWith As Boolean ' Return value +Dim lSub As Long ' Length of SUbstring +Const cstThisSub = "String.StartsWith" +Const cstSubArgs = "InputStr, Substring, [CaseSensitive=False]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bStartsWith = False + +Check: + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Substring, "Substring", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally + End If + +Try: + lSub = Len(Substring) + If Len(InputStr) > 0 And lSub > 0 And lSub <= Len(InputStr) Then + bStartsWith = ( StrComp(Left(InputStr, lSub), Substring, Iif(CaseSensitive, 1, 0)) = 0 ) + End If + +Finally: + StartsWith = bStartsWith + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.StartsWith + +REM ----------------------------------------------------------------------------- +Public Function TrimExt(Optional ByRef InputStr As Variant) As String +''' Return the input string without its leading and trailing whitespaces +''' Args: +''' InputStr: the input string +''' Returns: +''' The input string without its leading and trailing white spaces +''' Examples: +''' SF_String.TrimExt(" ABCDE" & Chr(9) & Chr(10) & Chr(13) & " ") returns "ABCDE" + +Dim sTrim As String ' Return value +Const cstThisSub = "String.TrimExt" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sTrim = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then + sTrim = SF_String.ReplaceRegex(InputStr, REGEXLTRIM, "") ' Trim left + sTrim = SF_String.ReplaceRegex(sTrim, REGEXRTRIM, "") ' Trim right + End If + +Finally: + TrimExt = sTrim + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.TrimExt + +REM ----------------------------------------------------------------------------- +Public Function Unescape(Optional ByRef InputStr As Variant) As String +''' Convert any escaped characters in the input string +''' Args: +''' InputStr: the input string +''' Returns: +''' The input string after replacement of \\, \n, \r, \t sequences +''' Examples: +''' SF_String.Unescape("abc\n\tdef\\n") returns "abc" & Chr(10) & Chr(9) & "def\n" + +Dim sUnescape As String ' Return value +Dim sToken As String ' Placeholder unlikely to be present in input string +Const cstThisSub = "String.Unescape" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sUnescape = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + End If + +Try: + sToken = Chr(1) & "$" & Chr(2) & "*" & Chr(3) & "$" & Chr(1) ' Placeholder for "\\" + sUnescape = SF_String.ReplaceStr( InputStr _ + , Array("\\", "\n", "\r", "\t", sToken) _ + , Array(sToken, SF_String.sfLF, SF_String.sfCR, SF_String.sfTAB, "\") _ + ) + +Finally: + Unescape = sUnescape + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Unescape + +REM ----------------------------------------------------------------------------- +Public Function Unquote(Optional ByRef InputStr As Variant _ + , Optional ByVal QuoteChar As String _ + ) As String +''' Reset a quoted string to its original content +''' (used f.i. for parsing of csv-like records) +''' When the input string contains the quote character, the latter must be escaped: +''' - QuoteChar = double quote, by doubling it ("") +''' - QuoteChar = single quote, with a preceding backslash (\') +''' Args: +''' InputStr: the input string +''' QuoteChar: either " (default) or ' +''' Returns: +''' The input string after removal of leading/trailing quotes and escaped single/double quotes +''' The input string if not a quoted string +''' Examples: +''' SF_String.Unquote("""àé""""n ΣlPµ Русский""") returns "àé""n ΣlPµ Русский" + +Dim sUnquote As String ' Return value +Dim oCharacterClass As Object ' com.sun.star.i18n.CharacterClassification +Dim oLocale As Object ' com.sun.star.lang.Locale +Dim oParse As Object ' com.sun.star.i18n.ParseResult +Const cstDouble = """" : Const cstSingle = "'" +Const cstThisSub = "String.Unquote" +Const cstSubArgs = "InputStr" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sUnquote = "" + +Check: + If IsMissing(QuoteChar) Or IsEmpty(QuoteChar) Then QuoteChar = cstDouble + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(QuoteChar, "QuoteChar", V_STRING, Array(cstDouble, cstSingle)) Then GoTo Finally + End If + +Try: + If Left(InputStr, 1) <> QuoteChar Then ' No need to parse further + sUnquote = InputStr + Else + Set oCharacterClass = SF_Utils._GetUNOService("CharacterClass") + Set oLocale = SF_Utils._GetUNOService("SystemLocale") + + ' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1i18n_1_1XCharacterClassification.html#ad5f1be91fbe86853200391f828d4166b + Set oParse = oCharacterClass.parsePredefinedToken( _ + Iif(QuoteChar = cstDouble, com.sun.star.i18n.KParseType.DOUBLE_QUOTE_STRING, com.sun.star.i18n.KParseType.SINGLE_QUOTE_NAME) _ + , InputStr, 0, oLocale, 0, "", 0, "") + If oParse.CharLen > 0 Then ' Is parsing successful ? + sUnquote = oParse.DequotedNameOrString + Else + sUnquote = InputStr + End If + End If + +Finally: + Unquote = sUnquote + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Unquote + +REM ----------------------------------------------------------------------------- +Public Function Wrap(Optional ByRef InputStr As Variant _ + , Optional ByVal Width As Variant _ + , Optional ByVal TabSize As Variant _ + ) As Variant +''' Wraps every single paragraph in text (a string) so every line is at most Width characters long +''' Args: +''' InputStr: the input string +''' Width: the maximum number of characters in each line, default = 70 +''' TabSize: before wrapping the text, the existing TAB (Chr(9)) characters are replaced with spaces. +''' TabSize defines the TAB positions at TabSize + 1, 2 * TabSize + 1 , ... N * TabSize + 1 +''' Default = 8 +''' Returns: +''' Returns a zero-based array of output lines, without final newlines except the pre-existing line-breaks +''' Tabs are expanded. Symbolic line breaks are replaced by their hard equivalents +''' If the wrapped output has no content, the returned array is empty. +''' Examples: +''' SF_String.Wrap("Neque porro quisquam est qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit...", 20) + +Dim vWrap As Variant ' Return value +Dim vWrapLines ' Input string split on line breaks +Dim sWrap As String ' Intermediate string +Dim sLine As String ' Line after splitting on line breaks +Dim lPos As Long ' Position in sLine already wrapped +Dim lStart As Long ' Start position before and after regex search +Dim sSpace As String ' Next whitespace +Dim sChunk As String ' Next wrappable text chunk +Const cstThisSub = "String.Wrap" +Const cstSubArgs = "InputStr, [Width=70], [TabSize=8]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vWrap = Array() + +Check: + If IsMissing(Width) Or IsEmpty(Width) Then Width = 70 + If IsMissing(TabSize) Or IsEmpty(TabSize) Then TabSize = 8 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Width, "Width", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(TabSize, "TabSize", V_NUMERIC) Then GoTo Finally + End If + +Try: + If Len(InputStr) > 0 Then + sWrap = SF_String.Unescape(InputStr) ' Replace symbolic breaks + sWrap = SF_String.ExpandTabs(sWrap, TabSize) ' Interpret TABs to have a meaningful Width + ' First, split full string + vWrapLines = SF_String.SplitLines(sWrap, KeepBreaks := True) ' Keep pre-existing breaks + If UBound(vWrapLines) = 0 And Len(sWrap) <= Width Then ' Output a single line + vWrap = Array(sWrap) + Else + ' Second, split each line on Width + For Each sLine In vWrapLines + If Len(sLine) <= Width Then + If UBound(vWrap) < 0 Then vWrap = Array(sLine) Else vWrap = SF_Array.Append(vWrap, sLine) + Else + ' Scan sLine and accumulate found substrings up to Width + lStart = 1 + lPos = 0 + sWrap = "" + Do While lStart <= Len(sLine) + sSpace = SF_String.FindRegex(sLine, REGEXSPACES, lStart) + If lStart = 0 Then lStart = Len(sLine) + 1 + sChunk = Mid(sLine, lPos + 1, lStart - 1 - lPos + Len(sSpace)) + If Len(sWrap) + Len(sChunk) < Width Then ' Add chunk to current piece of line + sWrap = sWrap & sChunk + Else ' Save current line and initialize next one + If UBound(vWrap) < 0 Then vWrap = Array(sWrap) Else vWrap = SF_Array.Append(vWrap, sWrap) + sWrap = sChunk + End If + lPos = lPos + Len(sChunk) + lStart = lPos + 1 + Loop + ' Add last chunk + If Len(sWrap) > 0 Then + If UBound(vWrap) < 0 Then vWrap = Array(sWrap) Else vWrap = SF_Array.Append(vWrap, sWrap) + End If + End If + Next sLine + End If + End If + +Finally: + Wrap = vWrap + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_String.Wrap + +REM ============================================================= PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Private Function _Repr(ByRef pvString As String) As String +''' Convert an arbitrary string to a readable string, typically for debugging purposes (DebugPrint ...) +''' Carriage Returns are replaced by \r. Other line breaks are replaced by \n +''' Tabs are replaced by \t +''' Backslashes are doubled +''' Other non printable characters are replaced by \x00 to \xFF or \x0000 to \xFFFF +''' Args: +''' pvString: the string to make readable +''' Return: +''' the converted string + +Dim sString As String ' Return value +Dim sChar As String ' A single character +Dim lAsc As Long ' Ascii value +Dim lPos As Long ' Position in sString +Dim i As Long + + ' Process TABs, CRs and LFs + sString = Replace(Replace(Replace(pvString, "\", "\\"), SF_String.sfCR, "\r"), SF_String.sfTAB, "\t") + sString = Join(SF_String.SplitLines(sString, KeepBreaks := False), "\n") + ' Process not printable characters + If Len(sString) > 0 Then + lPos = 1 + Do While lPos <= Len(sString) + sChar = Mid(sString, lPos, 1) + If Not SF_String.IsPrintable(sChar) Then + lAsc = Asc(sChar) + sChar = "\x" & Iif(lAsc < 255, Right("00" & Hex(lAsc), 2), Right("0000" & Hex(lAsc), 4)) + If lPos < Len(sString) Then + sString = Left(sString, lPos - 1) & sChar & Mid(sString, lPos + 1) + Else + sString = Left(sString, lPos - 1) & sChar + End If + End If + lPos = lPos + Len(sChar) + Loop + End If + + _Repr = sString + +End Function ' ScriptForge.SF_String._Repr + +REM ================================================ END OF SCRIPTFORGE.SF_STRING + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_TextStream.xba b/wizards/source/scriptforge/SF_TextStream.xba new file mode 100644 index 000000000..35f1b6fb2 --- /dev/null +++ b/wizards/source/scriptforge/SF_TextStream.xba @@ -0,0 +1,702 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_TextStream +''' ============= +''' Class instantiated by the +''' SF_FileSystem.CreateTextFile +''' SF_FileSystem.OpenTextFile +''' methods to facilitate the sequential processing of text files +''' All open/read/write/close operations are presumed to happen during the same macro run +''' The encoding to be used may be chosen by the user +''' The list is in the Name column of https://www.iana.org/assignments/character-sets/character-sets.xhtml +''' Note that probably not all values are available +''' Line delimiters may be chosen by the user +''' In input, CR, LF or CR+LF are supported +''' In output, the default value is the usual newline on the actual operating system (see SF_FileSystem.sfNEWLINE) +''' +''' The design choices are largely inspired by +''' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/textstream-object +''' The implementation is mainly based on the XTextInputStream and XTextOutputStream UNO interfaces +''' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1io_1_1XTextInputStream.html +''' https://api.libreoffice.org/docs/idl/ref/interfacecom_1_1sun_1_1star_1_1io_1_1XTextOutputStream.html +''' +''' Instantiation example: +''' Dim FSO As Object, myFile As Object +''' Set FSO = CreateScriptService("FileSystem") +''' Set myFile = FSO.OpenTextFile("C:\Temp\ThisFile.txt", FSO.ForReading) ' Once per file +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_textstream.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const FILENOTOPENERROR = "FILENOTOPENERROR" ' The file is already closed +Const FILEOPENMODEERROR = "FILEOPENMODEERROR" ' The file is open in incompatible mode +Const ENDOFFILEERROR = "ENDOFFILEERROR" ' When file was read, an end-of-file was encountered + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be TEXTSTREAM +Private ServiceName As String +Private _FileName As String ' File where it is about +Private _IOMode As Integer ' ForReading, ForWriting or ForAppending +Private _Encoding As String ' https://www.iana.org/assignments/character-sets/character-sets.xhtml +Private _NewLine As String ' Line break in write mode +Private _FileExists As Boolean ' True if file exists before open +Private _LineNumber As Long ' Number of lines read or written +Private _FileHandler As Object ' com.sun.star.io.XInputStream or + ' com.sun.star.io.XOutputStream or + ' com.sun.star.io.XStream +Private _InputStream As Object ' com.sun.star.io.TextInputStream +Private _OutputStream As Object ' com.sun.star.io.TextOutputStream +Private _ForceBlankLine As Boolean ' Workaround: XTextInputStream misses last line if file ends with newline + +REM ============================================================ MODULE CONSTANTS + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "TEXTSTREAM" + ServiceName = "ScriptForge.TextStream" + _FileName = "" + _IOMode = -1 + _Encoding = "" + _NewLine = "" + _FileExists = False + _LineNumber = 0 + Set _FileHandler = Nothing + Set _InputStream = Nothing + Set _OutputStream = Nothing + _ForceBlankLine = False +End Sub ' ScriptForge.SF_TextStream Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' ScriptForge.SF_TextStream Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' ScriptForge.SF_TextStream Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get AtEndOfStream() As Boolean +''' In reading mode, True indicates that the end of the file has been reached +''' In write and append modes, or if the file is not ready => always True +''' The property should be invoked BEFORE each ReadLine() method: +''' A ReadLine() executed while AtEndOfStream is True will raise an error +''' Example: +''' Dim sLine As String +''' Do While Not myFile.AtEndOfStream +''' sLine = myFile.ReadLine() +''' ' ... +''' Loop + + AtEndOfStream = _PropertyGet("AtEndOfStream") + +End Property ' ScriptForge.SF_TextStream.AtEndOfStream + +REM ----------------------------------------------------------------------------- +Property Get Encoding() As String +''' Returns the name of the text file either in url or in native operating system format +''' Example: +''' Dim myFile As Object +''' FSO.FileNaming = "SYS" +''' Set myFile = FSO.OpenTextFile("C:\Temp\myFile.txt") +''' MsgBox myFile.Encoding ' UTF-8 + + Encoding = _PropertyGet("Encoding") + +End Property ' ScriptForge.SF_TextStream.Encoding + +REM ----------------------------------------------------------------------------- +Property Get FileName() As String +''' Returns the name of the text file either in url or in native operating system format +''' Example: +''' Dim myFile As Object +''' FSO.FileNaming = "SYS" +''' Set myFile = FSO.OpenTextFile("C:\Temp\myFile.txt") +''' MsgBox myFile.FileName ' C:\Temp\myFile.txt + + FileName = _PropertyGet("FileName") + +End Property ' ScriptForge.SF_TextStream.FileName + +REM ----------------------------------------------------------------------------- +Property Get IOMode() As String +''' Returns either "READ", "WRITE" or "APPEND" +''' Example: +''' Dim myFile As Object +''' FSO.FileNaming = "SYS" +''' Set myFile = FSO.OpenTextFile("C:\Temp\myFile.txt") +''' MsgBox myFile.IOMode ' READ + + IOMode = _PropertyGet("IOMode") + +End Property ' ScriptForge.SF_TextStream.IOMode + +REM ----------------------------------------------------------------------------- +Property Get Line() As Long +''' Returns the number of lines read or written so far +''' Example: +''' Dim myFile As Object +''' FSO.FileNaming = "SYS" +''' Set myFile = FSO.OpenTextFile("C:\Temp\myFile.txt", FSO.ForAppending) +''' MsgBox myFile.Line ' The number of lines already present in myFile + + Line = _PropertyGet("Line") + +End Property ' ScriptForge.SF_TextStream.Line + +REM ----------------------------------------------------------------------------- +Property Get NewLine() As Variant +''' Returns the current character string to be inserted between 2 successive written lines +''' The default value is the native line separator in the current operating system +''' Example: +''' MsgBox myFile.NewLine + + NewLine = _PropertyGet("NewLine") + +End Property ' ScriptForge.SF_TextStream.NewLine (get) + +REM ----------------------------------------------------------------------------- +Property Let NewLine(ByVal pvLineBreak As Variant) +''' Sets the current character string to be inserted between 2 successive written lines +''' Example: +''' myFile.NewLine = Chr(13) & Chr(10) + +Const cstThisSub = "TextStream.setNewLine" + + SF_Utils._EnterFunction(cstThisSub) + If VarType(pvLineBreak) = V_STRING Then _NewLine = pvLineBreak + SF_Utils._ExitFunction(cstThisSub) + +End Property ' ScriptForge.SF_TextStream.NewLine (let) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function CloseFile() As Boolean +''' Empties the output buffer if relevant. Closes the actual input or output stream +''' Args: +''' Returns: +''' True if the closure was successful +''' Exceptions: +''' FILENOTOPENERROR Nothing found to close +''' Examples: +''' myFile.CloseFile() + +Dim bClose As Boolean ' Return value +Const cstThisSub = "TextStream.CloseFile" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsFileOpen() Then GoTo Finally + +Try: + If Not IsNull(_InputStream) Then _InputStream.closeInput() + If Not IsNull(_OutputStream) Then + _OutputStream.flush() + _OutputStream.closeOutput() + End If + Set _InputStream = Nothing + Set _OutputStream = Nothing + Set _FileHandler = Nothing + bClose = True + +Finally: + CloseFile = bClose + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_TextStream.CloseFile + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "TextStream.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_TextStream.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "CloseFile" _ + , "ReadAll" _ + , "readLine" _ + , "SkipLine" _ + , "WriteBlankLines" _ + , "WriteLine" _ + ) + +End Function ' ScriptForge.SF_TextStream.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "AtEndOfStream" _ + , "Encoding" _ + , "FileName" _ + , "IOMode" _ + , "Line" _ + , "NewLine" _ + ) + +End Function ' ScriptForge.SF_TextStream.Properties + +REM ----------------------------------------------------------------------------- +Public Function ReadAll() As String +''' Returns all the remaining lines in the text stream as one string. Line breaks are NOT removed +''' The resulting string can be split in lines +''' either by using the usual Split Basic builtin function if the line delimiter is known +''' or with the SF_String.SplitLines method +''' For large files, using the ReadAll method wastes memory resources. +''' Other techniques should be used to input a file, such as reading a file line-by-line +''' Args: +''' Returns: +''' The read lines. The string may be empty. +''' Note that the Line property in incremented only by 1 +''' Exceptions: +''' FILENOTOPENERROR File not open or already closed +''' FILEOPENMODEERROR File opened in write or append modes +''' ENDOFFILEERROR Previous reads already reached the end of the file +''' Examples: +''' Dim a As String +''' a = myFile.ReadAll() + +Dim sRead As String ' Return value +Const cstThisSub = "TextStream.ReadAll" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sRead = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsFileOpen("READ") Then GoTo Finally + If _InputStream.isEOF() Then GoTo CatchEOF + End If + +Try: + sRead = _InputStream.readString(Array(), False) + _LineNumber = _LineNumber + 1 + +Finally: + ReadAll = sRead + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchEOF: + SF_Exception.RaiseFatal(ENDOFFILEERROR, FileName) + GoTo Finally +End Function ' ScriptForge.SF_TextStream.ReadAll + +REM ----------------------------------------------------------------------------- +Public Function ReadLine() As String +''' Returns the next line in the text stream as a string. Line breaks are removed. +''' Args: +''' Returns: +''' The read line. The string may be empty. +''' Exceptions: +''' FILENOTOPENERROR File not open or already closed +''' FILEOPENMODEERROR File opened in write or append modes +''' ENDOFFILEERROR Previous reads already reached the end of the file +''' Examples: +''' Dim a As String +''' a = myFile.ReadLine() + +Dim sRead As String ' Return value +Dim iRead As Integer ' Length of line break +Const cstThisSub = "TextStream.ReadLine" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sRead = "" + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsFileOpen("READ") Then GoTo Finally + If AtEndOfStream Then GoTo CatchEOF + End If + +Try: + ' When the text file ends with a line break, + ' XTextInputStream.readLine() returns the line break together with the last line + ' Hence the workaround to force a blank line at the end + If _ForceBlankLine Then + sRead = "" + _ForceBlankLine = False + Else + sRead = _InputStream.readLine() + ' The isEOF() is set immediately after having read the last line + If _InputStream.isEOF() And Len(sRead) > 0 Then + iRead = 0 + If SF_String.EndsWith(sRead, SF_String.sfCRLF) Then + iRead = 2 + ElseIf SF_String.EndsWith(sRead, SF_String.sfLF) Or SF_String.EndsWith(sRead, SF_String.sfCR) Then + iRead = 1 + End If + If iRead > 0 Then + sRead = Left(sRead, Len(sRead) - iRead) + _ForceBlankLine = True ' Provision for a last empty line at the next read loop + End If + End If + End If + _LineNumber = _LineNumber + 1 + +Finally: + ReadLine = sRead + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchEOF: + SF_Exception.RaiseFatal(ENDOFFILEERROR, FileName) + GoTo Finally +End Function ' ScriptForge.SF_TextStream.ReadLine + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Dim bSet As Boolean ' Return value +Const cstThisSub = "TextStream.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + bSet = True + Select Case UCase(PropertyName) + Case "NEWLINE" + If Not SF_Utils._Validate(Value, "Value", V_STRING) Then GoTo Catch + NewLine = Value + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_TextStream.SetProperty + +REM ----------------------------------------------------------------------------- +Public Sub SkipLine() +''' Skips the next line when reading a TextStream file. +''' Args: +''' Exceptions: +''' FILENOTOPENERROR File not open or already closed +''' FILEOPENMODEERROR File opened in write or append modes +''' ENDOFFILEERROR Previous reads already reached the end of the file +''' Examples: +''' myFile.SkipLine() + +Dim sRead As String ' Read buffer +Const cstThisSub = "TextStream.SkipLine" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsFileOpen("READ") Then GoTo Finally + If Not _ForceBlankLine Then ' The file ends with a newline => return one empty line more + If _InputStream.isEOF() Then GoTo CatchEOF + End If + End If + +Try: + sRead = ReadLine() + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +CatchEOF: + SF_Exception.RaiseFatal(ENDOFFILEERROR, FileName) + GoTo Finally +End Sub ' ScriptForge.SF_TextStream.SkipLine + +REM ----------------------------------------------------------------------------- +Public Sub WriteBlankLines(Optional ByVal Lines As Variant) +''' Writes a number of empty lines in the output stream +''' Args: +''' Lines: the number of lines to write +''' Returns: +''' Exceptions: +''' FILENOTOPENERROR File not open or already closed +''' FILEOPENMODEERROR File opened in read mode +''' Examples: +''' myFile.WriteBlankLines(10) +Dim i As Long +Const cstThisSub = "TextStream.WriteBlankLines" +Const cstSubArgs = "Lines" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsFileOpen("WRITE") Then GoTo Finally + If Not SF_Utils._Validate(Lines, "Lines", V_NUMERIC) Then GoTo Finally + End If + +Try: + For i = 1 To Lines + _OutputStream.writeString(_NewLine) + Next i + _LineNumber = _LineNumber + Lines + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_TextStream.WriteBlankLines + +REM ----------------------------------------------------------------------------- +Public Sub WriteLine(Optional ByVal Line As Variant) +''' Writes the given line to the output stream. A newline is inserted if relevant +''' Args: +''' Line: the line to write, may be empty +''' Returns: +''' Exceptions: +''' FILENOTOPENERROR File not open or already closed +''' FILEOPENMODEERROR File opened in in read mode +''' Examples: +''' myFile.WriteLine("Next line") +Dim i As Long +Const cstThisSub = "TextStream.WriteLine" +Const cstSubArgs = "Line" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsFileOpen("WRITE") Then GoTo Finally + If Not SF_Utils._Validate(Line, "Line", V_STRING) Then GoTo Finally + End If + +Try: + _OutputStream.writeString(Iif(_LineNumber > 0, _NewLine, "") & Line) + _LineNumber = _LineNumber + 1 + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_TextStream.WriteLine + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Opens file and setup input and/or output streams (ForAppending requires both) + +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess + + ' Default newline related to current operating system + _NewLine = SF_String.sfNEWLINE + + Set oSfa = SF_Utils._GetUNOService("FileAccess") + + ' Setup input and/or output streams based on READ/WRITE/APPEND IO modes + Select Case _IOMode + Case SF_FileSystem.ForReading + Set _FileHandler = oSfa.openFileRead(_FileName) + Set _InputStream = CreateUnoService("com.sun.star.io.TextInputStream") + _InputStream.setInputStream(_FileHandler) + Case SF_FileSystem.ForWriting + ' Output file is deleted beforehand + If _FileExists Then oSfa.kill(_FileName) + Set _FileHandler = oSfa.openFileWrite(_FileName) + Set _OutputStream = CreateUnoService("com.sun.star.io.TextOutputStream") + _OutputStream.setOutputStream(_FileHandler) + Case SF_FileSystem.ForAppending + Set _FileHandler = oSfa.openFileReadWrite(_FileName) + Set _InputStream = CreateUnoService("com.sun.star.io.TextInputStream") + Set _OutputStream = CreateUnoService("com.sun.star.io.TextOutputStream") + _InputStream.setInputStream(_FileHandler) + ' Position at end of file: Skip and count existing lines + _LineNumber = 0 + Do While Not _InputStream.isEOF() + _InputStream.readLine() + _LineNumber = _LineNumber + 1 + Loop + _OutputStream.setOutputStream(_FileHandler) + End Select + + If _Encoding = "" Then _Encoding = "UTF-8" + If Not IsNull(_InputStream) Then _InputStream.setEncoding(_Encoding) + If Not IsNull(_OutputStream) Then _OutputStream.setEncoding(_Encoding) + +End Sub ' ScriptForge.SF_TextStream._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _IsFileOpen(Optional ByVal psMode As String) As Boolean +''' Checks if file is open with the right mode (READ or WRITE) +''' Raises an exception if the file is not open at all or not in the right mode +''' Args: +''' psMode: READ or WRITE or zero-length string +''' Exceptions: +''' FILENOTOPENERROR File not open or already closed +''' FILEOPENMODEERROR File opened in incompatible mode + + _IsFileOpen = False + If IsMissing(psMode) Then psMode = "" + If IsNull(_InputStream) And IsNull(_OutputStream) Then GoTo CatchNotOpen + Select Case psMode + Case "READ" + If IsNull(_InputStream) Then GoTo CatchOpenMode + If _IOMode <> SF_FileSystem.ForReading Then GoTo CatchOpenMode + Case "WRITE" + If IsNull(_OutputStream) Then GoTo CatchOpenMode + If _IOMode = SF_FileSystem.ForReading Then GoTo CatchOpenMode + Case Else + End Select + _IsFileOpen = True + +Finally: + Exit Function +CatchNotOpen: + SF_Exception.RaiseFatal(FILENOTOPENERROR, FileName) + GoTo Finally +CatchOpenMode: + SF_Exception.RaiseFatal(FILEOPENMODEERROR, FileName, IOMode) + GoTo Finally +End Function ' ScriptForge.SF_TextStream._IsFileOpen + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Dim cstSubArgs As String + + cstThisSub = "TextStream.get" & psProperty + cstSubArgs = "" + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case UCase(psProperty) + Case UCase("AtEndOfStream") + Select Case _IOMode + Case SF_FileSystem.ForReading + If IsNull(_InputStream) Then _PropertyGet = True Else _PropertyGet = CBool(_InputStream.isEOF() And Not _ForceBlankLine) + Case Else : _PropertyGet = True + End Select + Case UCase("Encoding") + _PropertyGet = _Encoding + Case UCase("FileName") + _PropertyGet = SF_FileSystem._ConvertFromUrl(_FileName) ' Depends on FileNaming + Case UCase("IOMode") + With SF_FileSystem + Select Case _IOMode + Case .ForReading : _PropertyGet = "READ" + Case .ForWriting : _PropertyGet = "WRITE" + Case .ForAppending : _PropertyGet = "APPEND" + Case Else : _PropertyGet = "" + End Select + End With + Case UCase("Line") + _PropertyGet = _LineNumber + Case UCase("NewLine") + _PropertyGet = _NewLine + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_TextStream._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the TextStream instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[TextStream]: File name, IOMode, LineNumber" + + _Repr = "[TextStream]: " & FileName & "," & IOMode & "," & CStr(Line) + +End Function ' ScriptForge.SF_TextStream._Repr + +REM ============================================ END OF SCRIPTFORGE.SF_TextStream + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Timer.xba b/wizards/source/scriptforge/SF_Timer.xba new file mode 100644 index 000000000..2b3286e04 --- /dev/null +++ b/wizards/source/scriptforge/SF_Timer.xba @@ -0,0 +1,466 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Timer +''' ======== +''' Class for management of scripts execution performance +''' A Timer measures durations. It can be suspended, resumed, restarted +''' Duration properties are expressed in seconds with a precision of 3 decimal digits +''' +''' Service invocation example: +''' Dim myTimer As Variant +''' myTimer = CreateScriptService("Timer") +''' myTimer = CreateScriptService("Timer", True) ' => To start timer immediately +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_timer.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "TIMER" +Private ServiceName As String +Private _TimerStatus As Integer ' inactive, started, suspended or stopped +Private _StartTime As Double ' Moment when timer started, restarted +Private _EndTime As Double ' Moment when timer stopped +Private _SuspendTime As Double ' Moment when timer suspended +Private _SuspendDuration As Double ' Duration of suspended status as a difference of times + +REM ============================================================ MODULE CONSTANTS + +Private Const STATUSINACTIVE = 0 +Private Const STATUSSTARTED = 1 +Private Const STATUSSUSPENDED = 2 +Private Const STATUSSTOPPED = 3 + +Private Const DSECOND As Double = 1 / (24 * 60 * 60) ' Duration of 1 second as compared to 1.0 = 1 day + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "TIMER" + ServiceName = "ScriptForge.Timer" + _TimerStatus = STATUSINACTIVE + _StartTime = 0 + _EndTime = 0 + _SuspendTime = 0 + _SuspendDuration = 0 +End Sub ' ScriptForge.SF_Timer Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' ScriptForge.SF_Timer Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' ScriptForge.SF_Timer Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Public Function Duration() As Double +''' Returns the actual (out of suspensions) time elapsed since start or between start and stop +''' Args: +''' Returns: +''' A Double expressing the duration in seconds +''' Example: +''' myTimer.Duration returns 1.234 (1 sec, 234 ms) + + Duration = _PropertyGet("Duration") + +End Function ' ScriptForge.SF_Timer.Duration + +REM ----------------------------------------------------------------------------- +Property Get IsStarted() As Boolean +''' Returns True if timer is started or suspended +''' Example: +''' myTimer.IsStarted + + IsStarted = _PropertyGet("IsStarted") + +End Property ' ScriptForge.SF_Timer.IsStarted + +REM ----------------------------------------------------------------------------- +Property Get IsSuspended() As Boolean +''' Returns True if timer is started and suspended +''' Example: +''' myTimer.IsSuspended + + IsSuspended = _PropertyGet("IsSuspended") + +End Property ' ScriptForge.SF_Timer.IsSuspended + +REM ----------------------------------------------------------------------------- +Public Function SuspendDuration() As Double +''' Returns the actual time elapsed while suspended since start or between start and stop +''' Args: +''' Returns: +''' A Double expressing the duration in seconds +''' Example: +''' myTimer.SuspendDuration returns 1.234 (1 sec, 234 ms) + + SuspendDuration = _PropertyGet("SuspendDuration") + +End Function ' ScriptForge.SF_Timer.SuspendDuration + +REM ----------------------------------------------------------------------------- +Public Function TotalDuration() As Double +''' Returns the actual time elapsed (including suspensions) since start or between start and stop +''' Args: +''' Returns: +''' A Double expressing the duration in seconds +''' Example: +''' myTimer.TotalDuration returns 1.234 (1 sec, 234 ms) + + TotalDuration = _PropertyGet("TotalDuration") + +End Function ' ScriptForge.SF_Timer.TotalDuration + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Continue() As Boolean +''' Halt suspension of a running timer +''' Args: +''' Returns: +''' True if successful, False if the timer is not suspended +''' Examples: +''' myTimer.Continue() + +Const cstThisSub = "Timer.Continue" +Const cstSubArgs = "" + +Check: + Continue = False + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If _TimerStatus = STATUSSUSPENDED Then + _TimerStatus = STATUSSTARTED + _SuspendDuration = _SuspendDuration + _Now() - _SuspendTime + _SuspendTime = 0 + Continue = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Timer.Continue + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myTimer.GetProperty("Duration") + +Const cstThisSub = "Timer.GetProperty" +Const cstSubArgs = "PropertyName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Timer.Properties + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list or methods of the Timer class as an array + + Methods = Array( _ + "Continue" _ + , "Restart" _ + , "Start" _ + , "Suspend" _ + , "Terminate" _ + ) + +End Function ' ScriptForge.SF_Timer.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "Duration" _ + , "IsStarted" _ + , "IsSuspended" _ + , "SuspendDuration" _ + , "TotalDuration" _ + ) + +End Function ' ScriptForge.SF_Timer.Properties + +REM ----------------------------------------------------------------------------- +Public Function Restart() As Boolean +''' Terminate the timer and restart a new clean timer +''' Args: +''' Returns: +''' True if successful, False if the timer is inactive +''' Examples: +''' myTimer.Restart() + +Const cstThisSub = "Timer.Restart" +Const cstSubArgs = "" + +Check: + Restart = False + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If _TimerStatus <> STATUSINACTIVE Then + If _TimerStatus <> STATUSSTOPPED Then Terminate() + Start() + Restart = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Timer.Restart + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "Timer.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Timer.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Start() As Boolean +''' Start a new clean timer +''' Args: +''' Returns: +''' True if successful, False if the timer is already started +''' Examples: +''' myTimer.Start() + +Const cstThisSub = "Timer.Start" +Const cstSubArgs = "" + +Check: + Start = False + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If _TimerStatus = STATUSINACTIVE Or _TimerStatus = STATUSSTOPPED Then + _TimerStatus = STATUSSTARTED + _StartTime = _Now() + _EndTime = 0 + _SuspendTime = 0 + _SuspendDuration = 0 + Start = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Timer.Start + +REM ----------------------------------------------------------------------------- +Public Function Suspend() As Boolean +''' Suspend a running timer +''' Args: +''' Returns: +''' True if successful, False if the timer is not started or already suspended +''' Examples: +''' myTimer.Suspend() + +Const cstThisSub = "Timer.Suspend" +Const cstSubArgs = "" + +Check: + Suspend = False + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If _TimerStatus = STATUSSTARTED Then + _TimerStatus = STATUSSUSPENDED + _SuspendTime = _Now() + Suspend = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Timer.Suspend + +REM ----------------------------------------------------------------------------- +Public Function Terminate() As Boolean +''' Terminate a running timer +''' Args: +''' Returns: +''' True if successful, False if the timer is neither started nor suspended +''' Examples: +''' myTimer.Terminate() + +Const cstThisSub = "Timer.Terminate" +Const cstSubArgs = "" + +Check: + Terminate = False + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + If _TimerStatus = STATUSSTARTED Or _TimerStatus = STATUSSUSPENDED Then + If _TimerSTatus = STATUSSUSPENDED Then Continue() + _TimerStatus = STATUSSTOPPED + _EndTime = _Now() + Terminate = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Timer.Terminate + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _Now() As Double +''' Returns the current date and time +''' Uses the Calc NOW() function to get a higher precision than the usual Basic Now() function +''' Args: +''' Returns: +''' The actual time as a number +''' The integer part represents the date, the decimal part represents the time + + _Now = SF_Session.ExecuteCalcFunction("NOW") + +End Function ' ScriptForge.SF_Timer._Now + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) +''' Return the named property +''' Args: +''' psProperty: the name of the property + +Dim dDuration As Double ' Computed duration +Dim cstThisSub As String +Dim cstSubArgs As String + + cstThisSub = "Timer.get" & psProperty + cstSubArgs = "" + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case UCase(psProperty) + Case UCase("Duration") + Select Case _TimerStatus + Case STATUSINACTIVE : dDuration = 0.0 + Case STATUSSTARTED + dDuration = _Now() - _StartTime - _SuspendDuration + Case STATUSSUSPENDED + dDuration = _SuspendTime - _StartTime - _SuspendDuration + Case STATUSSTOPPED + dDuration = _EndTime - _StartTime - _SuspendDuration + End Select + _PropertyGet = Fix(dDuration * 1000 / DSECOND) / 1000 + Case UCase("IsStarted") + _PropertyGet = CBool( _TimerStatus = STATUSSTARTED Or _TimerStatus = STATUSSUSPENDED ) + Case UCase("IsSuspended") + _PropertyGet = CBool( _TimerStatus = STATUSSUSPENDED ) + Case UCase("SuspendDuration") + Select Case _TimerStatus + Case STATUSINACTIVE : dDuration = 0.0 + Case STATUSSTARTED, STATUSSTOPPED + dDuration = _SuspendDuration + Case STATUSSUSPENDED + dDuration = _Now() - _SuspendTime + _SuspendDuration + End Select + _PropertyGet = Fix(dDuration * 1000 / DSECOND) / 1000 + Case UCase("TotalDuration") + Select Case _TimerStatus + Case STATUSINACTIVE : dDuration = 0.0 + Case STATUSSTARTED, STATUSSUSPENDED + dDuration = _Now() - _StartTime + Case STATUSSTOPPED + dDuration = _EndTime - _StartTime + End Select + _PropertyGet = Fix(dDuration * 1000 / DSECOND) / 1000 + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Timer._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Timer instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Timer] Duration:xxx.yyy + +Const cstTimer = "[Timer] Duration: " +Const cstMaxLength = 50 ' Maximum length for items + + _Repr = cstTimer & Replace(SF_Utils._Repr(Duration), ".", """") + +End Function ' ScriptForge.SF_Timer._Repr + +REM ============================================ END OF SCRIPTFORGE.SF_TIMER + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_UI.xba b/wizards/source/scriptforge/SF_UI.xba new file mode 100644 index 000000000..c8a7f9a8f --- /dev/null +++ b/wizards/source/scriptforge/SF_UI.xba @@ -0,0 +1,1350 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_UI +''' ===== +''' Singleton class module for the identification and the manipulation of the +''' different windows composing the whole LibreOffice application: +''' - Windows selection +''' - Windows moving and resizing +''' - Statusbar settings +''' - Creation of new windows +''' - Access to the underlying "documents" +''' +''' WindowName: how to designate a window. It can be either +''' a full FileName given in the notation indicated by the current value of SF_FileSystem.FileNaming +''' or the last component of the full FileName or even only its BaseName +''' or the title of the window +''' or, for new documents, something like "Untitled 1" +''' or one of the special windows "BASICIDE" and "WELCOMESCREEN" +''' The window search is case-sensitive +''' +''' Service invocation example: +''' Dim ui As Variant +''' ui = CreateScriptService("UI") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_ui.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Const DOCUMENTERROR = "DOCUMENTERROR" ' Requested document was not found +Const DOCUMENTCREATIONERROR = "DOCUMENTCREATIONERROR" ' Incoherent arguments, new document could not be created +Const DOCUMENTOPENERROR = "DOCUMENTOPENERROR" ' Document could not be opened, check the arguments +Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR" ' Id. for Base document +Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" ' Calc datasource does not exist + +REM ============================================================= PRIVATE MEMBERS + +Type Window + Component As Object ' com.sun.star.lang.XComponent + Frame As Object ' com.sun.star.comp.framework.Frame + WindowName As String ' Object Name + WindowTitle As String ' Only mean to identify new documents + WindowFileName As String ' URL of file name + DocumentType As String ' Writer, Calc, ... +End Type + +' The progress/status bar of the active window +'Private oStatusBar As Object ' com.sun.star.task.XStatusIndicator + +REM ============================================================ MODULE CONSTANTS + +' Special windows +Const BASICIDE = "BASICIDE" +Const WELCOMESCREEN = "WELCOMESCREEN" + +' Document types (only if not 1 of the special windows) +Const BASEDOCUMENT = "Base" +Const CALCDOCUMENT = "Calc" +Const DRAWDOCUMENT = "Draw" +Const IMPRESSDOCUMENT = "Impress" +Const MATHDOCUMENT = "Math" +Const WRITERDOCUMENT = "Writer" + +' Window subtypes - Not supported yet +Const BASETABLE = "BASETABLE" +Const BASEQUERY = "BASEQUERY" +Const BASEREPORT = "BASEREPORT" +Const BASEDIAGRAM = "BASEDIAGRAM" + +' Macro execution modes +Const cstMACROEXECNORMAL = 0 ' Default, execution depends on user configuration and choice +Const cstMACROEXECNEVER = 1 ' Macros are not executed +Const cstMACROEXECALWAYS = 2 ' Macros are always executed + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Set Dispose = Nothing +End Function ' ScriptForge.SF_UI Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Public Function ActiveWindow() As String +''' Returns a valid WindowName for the currently active window +''' When "" is returned, the window could not be identified + +Dim vWindow As Window ' A component +Dim oComp As Object ' com.sun.star.lang.XComponent + + Set oComp = StarDesktop.CurrentComponent + If Not IsNull(oComp) Then + vWindow = SF_UI._IdentifyWindow(oComp) + With vWindow + If Len(.WindowFileName) > 0 Then + ActiveWindow = SF_FileSystem._ConvertFromUrl(.WindowFileName) + ElseIf Len(.WindowName) > 0 Then + ActiveWindow = .WindowName + ElseIf Len(.WindowTitle) > 0 Then + ActiveWindow = .WindowTitle + Else + ActiveWindow = "" + End If + End With + End If + +End Function ' ScriptForge.SF_UI.ActiveWindow + +REM ----------------------------------------------------------------------------- +Property Get Height() As Long +''' Returns the height of the active window +Dim oPosSize As Object ' com.sun.star.awt.Rectangle + Set oPosSize = SF_UI._PosSize() + If Not IsNull(oPosSize) Then Height = oPosSize.Height Else Height = -1 +End Property ' ScriptForge.SF_UI.Height + +REM ----------------------------------------------------------------------------- +Property Get MACROEXECALWAYS As Integer +''' Macros are always executed + MACROEXECALWAYS = cstMACROEXECALWAYS +End Property ' ScriptForge.SF_UI.MACROEXECALWAYS + +REM ----------------------------------------------------------------------------- +Property Get MACROEXECNEVER As Integer +''' Macros are not executed + MACROEXECNEVER = cstMACROEXECNEVER +End Property ' ScriptForge.SF_UI.MACROEXECNEVER + +REM ----------------------------------------------------------------------------- +Property Get MACROEXECNORMAL As Integer +''' Default, execution depends on user configuration and choice + MACROEXECNORMAL = cstMACROEXECNORMAL +End Property ' ScriptForge.SF_UI.MACROEXECNORMAL + +REM ----------------------------------------------------------------------------- +Property Get ObjectType As String +''' Only to enable object representation + ObjectType = "SF_UI" +End Property ' ScriptForge.SF_UI.ObjectType + +REM ----------------------------------------------------------------------------- +Property Get ServiceName As String +''' Internal use + ServiceName = "ScriptForge.UI" +End Property ' ScriptForge.SF_UI.ServiceName + +REM ----------------------------------------------------------------------------- +Property Get Width() As Long +''' Returns the width of the active window +Dim oPosSize As Object ' com.sun.star.awt.Rectangle + Set oPosSize = SF_UI._PosSize() + If Not IsNull(oPosSize) Then Width = oPosSize.Width Else Width = -1 +End Property ' ScriptForge.SF_UI.Width + +REM ----------------------------------------------------------------------------- +Property Get X() As Long +''' Returns the X coordinate of the active window +Dim oPosSize As Object ' com.sun.star.awt.Rectangle + Set oPosSize = SF_UI._PosSize() + If Not IsNull(oPosSize) Then X = oPosSize.X Else X = -1 +End Property ' ScriptForge.SF_UI.X + +REM ----------------------------------------------------------------------------- +Property Get Y() As Long +''' Returns the Y coordinate of the active window +Dim oPosSize As Object ' com.sun.star.awt.Rectangle + Set oPosSize = SF_UI._PosSize() + If Not IsNull(oPosSize) Then Y = oPosSize.Y Else Y = -1 +End Property ' ScriptForge.SF_UI.Y + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate(Optional ByVal WindowName As Variant) As Boolean +''' Make the specified window active +''' Args: +''' WindowName: see definitions +''' Returns: +''' True if the given window is found and can be activated +''' There is no change in the actual user interface if no window matches the selection +''' Examples: +''' ui.Activate("C:\Me\My file.odt") + +Dim bActivate As Boolean ' Return value +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "UI.Activate" +Const cstSubArgs = "WindowName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActivate = False + +Check: + If IsMissing(WindowName) Or IsEmpty(WindowName) Then WindowName = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(WindowName, "WindowName") Then GoTo Finally + End If + +Try: + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + vWindow = SF_UI._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the arguments ? + If (Len(.WindowFileName) > 0 And .WindowFileName = SF_FileSystem._ConvertToUrl(WindowName)) _ + Or (Len(.WindowName) > 0 And .WindowName = WindowName) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = WindowName) Then + Set oContainer = vWindow.Frame.ContainerWindow + With oContainer + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .toFront() ' Force window change in Linux + Wait 1 ' Bypass desynchro issue in Linux + End With + bActivate = True + Exit Do + End If + End With + Loop + +Finally: + Activate = bActivate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_UI.Activate + +REM ----------------------------------------------------------------------------- +Public Function CreateBaseDocument(Optional ByVal FileName As Variant _ + , Optional ByVal EmbeddedDatabase As Variant _ + , Optional ByVal RegistrationName As Variant _ + , Optional ByVal CalcFileName As Variant _ + ) As Object +''' Create a new LibreOffice Base document embedding an empty database of the given type +''' Args: +''' FileName: Identifies the file to create. It must follow the SF_FileSystem.FileNaming notation +''' If the file already exists, it is overwritten without warning +''' EmbeddedDatabase: either "HSQLDB" (default) or "FIREBIRD" or "CALC" +''' RegistrationName: the name used to store the new database in the databases register +''' If "" (default), no registration takes place +''' If the name already exists it is overwritten without warning +''' CalcFileName: only when EmbedddedDatabase = "CALC", the name of the file containing the tables as Calc sheets +''' The name of the file must be given in SF_FileSystem.FileNaming notation +''' The file must exist +''' Returns: +''' A SFDocuments.SF_Document object or one of its subclasses +''' Exceptions +''' UNKNOWNFILEERROR Calc datasource does not exist +''' Examples: +''' Dim myBase As Object, myCalcBase As Object +''' Set myBase = ui.CreateBaseDocument("C:\Databases\MyBaseFile.odb", "FIREBIRD") +''' Set myCalcBase = ui.CreateBaseDocument("C:\Databases\MyCalcBaseFile.odb", "CALC", , "C:\Databases\MyCalcFile.ods") + +Dim oCreate As Variant ' Return value +Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext +Dim oDatabase As Object ' com.sun.star.comp.dba.ODatabaseSource +Dim oComp As Object ' Loaded component com.sun.star.lang.XComponent +Dim sFileName As String ' Alias of FileName +Dim FSO As Object ' Alias for FileSystem service +Const cstDocType = "private:factory/s" +Const cstThisSub = "UI.CreateBaseDocument" +Const cstSubArgs = "FileName, [EmbeddedDatabase=""HSQLDB""|""FIREBIRD""|""CALC""], [RegistrationName=""""], [CalcFileName]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oCreate = Nothing + Set FSO = CreateScriptService("FileSystem") + +Check: + If IsMissing(EmbeddedDatabase) Or IsEmpty(EmbeddedDatabase) Then EmbeddedDatabase = "HSQLDB" + If IsMissing(RegistrationName) Or IsEmpty(RegistrationName) Then RegistrationName = "" + If IsMissing(CalcFileName) Or IsEmpty(CalcFileName) Then CalcFileName = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(EmbeddedDatabase, "EmbeddedDatabase", V_STRING, Array("CALC", "HSQLDB", "FIREBIRD")) Then GoTo Finally + If Not SF_Utils._Validate(RegistrationName, "RegistrationName", V_STRING) Then GoTo Finally + If UCase(EmbeddedDatabase) = "CALC" Then + If Not SF_Utils._ValidateFile(CalcFileName, "CalcFileName") Then GoTo Finally + If Not FSO.FileExists(CalcFileName) Then GoTo CatchNotExists + End If + End If + +Try: + Set oDBContext = SF_Utils._GetUNOService("DatabaseContext") + With oDBContext + Set oDatabase = .createInstance() + ' Build the url link to the database + Select Case UCase(EmbeddedDatabase) + Case "HSQLDB", "FIREBIRD" + oDatabase.URL = "sdbc:embedded:" & LCase(EmbeddedDatabase) + Case "CALC" + oDatabase.URL = "sdbc:calc:" & FSO._ConvertToUrl(CalcFileName) + End Select + ' Create empty Base document + sFileName = FSO._ConvertToUrl(FileName) + ' An existing file is overwritten without warning + If FSO.FileExists(FileName) Then FSO.DeleteFile(FileName) + If FSO.FileExists(FileName & ".lck") Then FSO.DeleteFile(FileName & ".lck") + oDatabase.DatabaseDocument.storeAsURL(sFileName, Array(SF_Utils._MakePropertyValue("Overwrite", True))) + ' Register database if requested + If Len(RegistrationName) > 0 Then + If .hasRegisteredDatabase(RegistrationName) Then + .changeDatabaseLocation(RegistrationName, sFileName) + Else + .registerDatabaseLocation(RegistrationName, sFileName) + End If + End If + End With + + Set oCreate = OpenBaseDocument(FileName) + +Finally: + Set CreateBaseDocument = oCreate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "CalcFileName", CalcFileName) + GoTo Finally +End Function ' ScriptForge.SF_UI.CreateBaseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateDocument(Optional ByVal DocumentType As Variant _ + , Optional ByVal TemplateFile As Variant _ + , Optional ByVal Hidden As Variant _ + ) As Object +''' Create a new LibreOffice document of a given type or based on a given template +''' Args: +''' DocumentType: "Calc", "Writer", etc. If absent, a TemplateFile must be given +''' TemplateFile: the full FileName of the template to build the new document on +''' If the file does not exist, the argument is ignored +''' The "FileSystem" service provides the TemplatesFolder and UserTemplatesFolder +''' properties to help to build the argument +''' Hidden: if True, open in the background (default = False) +''' To use with caution: activation or closure can only happen programmatically +''' Returns: +''' A SFDocuments.SF_Document object or one of its subclasses +''' Exceptions: +''' DOCUMENTCREATIONERROR Wrong arguments +''' Examples: +''' Dim myDoc1 As Object, myDoc2 As Object, FSO As Object +''' Set myDoc1 = ui.CreateDocument("Calc") +''' Set FSO = CreateScriptService("FileSystem") +''' Set myDoc2 = ui.CreateDocument(, FSO.BuildPath(FSO.TemplatesFolder, "personal/CV.ott")) + +Dim oCreate As Variant ' Return value +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim bTemplateExists As Boolean ' True if TemplateFile is valid +Dim sNew As String ' File url +Dim oComp As Object ' Loaded component com.sun.star.lang.XComponent +Const cstDocType = "private:factory/s" +Const cstThisSub = "UI.CreateDocument" +Const cstSubArgs = "[DocumentType=""""], [TemplateFile=""""], [Hidden=False]" + +'>>> If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oCreate = Nothing + +Check: + If IsMissing(DocumentType) Or IsEmpty(DocumentType) Then DocumentType = "" + If IsMissing(TemplateFile) Or IsEmpty(TemplateFile) Then TemplateFile = "" + If IsMissing(Hidden) Or IsEmpty(Hidden) Then Hidden = False + + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(DocumentType, "DocumentType", V_STRING _ + , Array("", BASEDOCUMENT, CALCDOCUMENT, DRAWDOCUMENT _ + , IMPRESSDOCUMENT, MATHDOCUMENT, WRITERDOCUMENT)) Then GoTo Finally + If Not SF_Utils._ValidateFile(TemplateFile, "TemplateFile", , True) Then GoTo Finally + If Not SF_Utils._Validate(Hidden, "Hidden", V_BOOLEAN) Then GoTo Finally + End If + + If Len(DocumentType) + Len(TemplateFile) = 0 Then GoTo CatchError + If Len(TemplateFile) > 0 Then bTemplateExists = SF_FileSystem.FileExists(TemplateFile) Else bTemplateExists = False + If Len(DocumentType) = 0 Then + If Not bTemplateExists Then GoTo CatchError + End If + +Try: + If bTemplateExists Then sNew = SF_FileSystem._ConvertToUrl(TemplateFile) Else sNew = cstDocType & LCase(DocumentType) + vProperties = Array( _ + SF_Utils._MakePropertyValue("AsTemplate", bTemplateExists) _ + , SF_Utils._MakePropertyValue("Hidden", Hidden) _ + ) + Set oComp = StarDesktop.loadComponentFromURL(sNew, "_blank", 0, vProperties) + If Not IsNull(oComp) Then Set oCreate = CreateScriptService("SFDocuments.Document", oComp) + +Finally: + Set CreateDocument = oCreate + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + SF_Exception.RaiseFatal(DOCUMENTCREATIONERROR, "DocumentType", DocumentType, "TemplateFile", TemplateFile) + GoTo Finally +End Function ' ScriptForge.SF_UI.CreateDocument + +REM ----------------------------------------------------------------------------- +Public Function Documents() As Variant +''' Returns the list of the currently open documents. Special windows are ignored. +''' Returns: +''' A zero-based 1D array of filenames (in SF_FileSystem.FileNaming notation) +''' or of window titles for unsaved documents +''' Examples: +''' Dim vDocs As Variant, sDoc As String +''' vDocs = ui.Documents() +''' For each sDoc In vDocs +''' ... + +Dim vDocuments As Variant ' Return value +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Const cstThisSub = "UI.Documents" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vDocuments = Array() + +Check: + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + vWindow = SF_UI._IdentifyWindow(oComp) + With vWindow + If Len(.WindowFileName) > 0 Then + vDocuments = SF_Array.Append(vDocuments, SF_FileSystem._ConvertFromUrl(.WindowFileName)) + ElseIf Len(.WindowTitle) > 0 Then + vDocuments = SF_Array.Append(vDocuments, .WindowTitle) + End If + End With + Loop + +Finally: + Documents = vDocuments + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_UI.Documents + +REM ----------------------------------------------------------------------------- +Public Function GetDocument(Optional ByVal WindowName As Variant) As Variant +''' Returns a SFDocuments.Document object referring to the active window or the given window +''' Args: +''' WindowName: when a string, see definitions. If absent the active window is considered. +''' when an object, must be a UNO object of types +''' com.sun.star.lang.XComponent or com.sun.star.comp.dba.ODatabaseDocument +''' Exceptions: +''' DOCUMENTERROR The targeted window could not be found +''' Examples: +''' Dim oDoc As Object +''' Set oDoc = ui.GetDocument ' or Set oDoc = ui.GetDocument(ThisComponent) +''' oDoc.Save() + +Dim oDocument As Object ' Return value +Const cstThisSub = "UI.GetDocument" +Const cstSubArgs = "[WindowName]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oDocument = Nothing + +Check: + If IsMissing(WindowName) Or IsEmpty(WindowName) Then WindowName = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(WindowName, "WindowName", Array(V_STRING, V_OBJECT)) Then GoTo Finally + If VarType(WindowName) = V_STRING Then + If Not SF_Utils._ValidateFile(WindowName, "WindowName", , True) Then GoTo Finally + End If + End If + +Try: + Set oDocument = SF_Services.CreateScriptService("SFDocuments.Document", WindowName) + If IsNull(oDocument) Then GoTo CatchDeliver + +Finally: + Set GetDocument = oDocument + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDeliver: + SF_Exception.RaiseFatal(DOCUMENTERROR, "WindowName", WindowName) + GoTo Finally +End Function ' ScriptForge.SF_UI.GetDocument + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "UI.GetProperty" +Const cstSubArgs = "PropertyName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case "ACTIVEWINDOW" : GetProperty = ActiveWindow() + Case "HEIGHT" : GetProperty = SF_UI.Height + Case "WIDTH" : GetProperty = SF_UI.Width + Case "X" : GetProperty = SF_UI.X + Case "Y" : GetProperty = SF_UI.Y + + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_UI.GetProperty + +REM ----------------------------------------------------------------------------- +Public Sub Maximize(Optional ByVal WindowName As Variant) +''' Maximizes the active window or the given window +''' Args: +''' WindowName: see definitions. If absent the active window is considered +''' Examples: +''' ui.Maximize +''' ... + +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Dim oContainer As Object ' com.sun.star.awt.XWindow +Dim bFound As Boolean ' True if window found +Const cstThisSub = "UI.Maximize" +Const cstSubArgs = "[WindowName]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(WindowName) Or IsEmpty(WindowName) Then WindowName = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(WindowName, "WindowName", , True) Then GoTo Finally + End If + +Try: + bFound = False + If Len(WindowName) > 0 Then + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements And Not bFound + Set oComp = oEnum.nextElement + vWindow = SF_UI._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the arguments ? + If (Len(.WindowFileName) > 0 And .WindowFileName = SF_FileSystem.ConvertToUrl(WindowName)) _ + Or (Len(.WindowName) > 0 And .WindowName = WindowName) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = WindowName) Then bFound = True + End With + Loop + Else + vWindow = SF_UI._IdentifyWindow(StarDesktop.CurrentComponent) + bFound = True + End If + + If bFound Then + Set oContainer = vWindow.Frame.ContainerWindow + oContainer.IsMaximized = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_UI.Maximize + +REM ----------------------------------------------------------------------------- +Public Sub Minimize(Optional ByVal WindowName As Variant) +''' Minimizes the current window or the given window +''' Args: +''' WindowName: see definitions. If absent the current window is considered +''' Examples: +''' ui.Minimize("myFile.ods") +''' ... + +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Dim oContainer As Object ' com.sun.star.awt.XWindow +Dim bFound As Boolean ' True if window found +Const cstThisSub = "UI.Minimize" +Const cstSubArgs = "[WindowName]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(WindowName) Or IsEmpty(WindowName) Then WindowName = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(WindowName, "WindowName", , True) Then GoTo Finally + End If + +Try: + bFound = False + If Len(WindowName) > 0 Then + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements And Not bFound + Set oComp = oEnum.nextElement + vWindow = SF_UI._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the arguments ? + If (Len(.WindowFileName) > 0 And .WindowFileName = SF_FileSystem.ConvertToUrl(WindowName)) _ + Or (Len(.WindowName) > 0 And .WindowName = WindowName) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = WindowName) Then bFound = True + End With + Loop + Else + vWindow = SF_UI._IdentifyWindow(StarDesktop.CurrentComponent) + bFound = True + End If + + If bFound Then + Set oContainer = vWindow.Frame.ContainerWindow + oContainer.IsMinimized = True + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_UI.Minimize + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the UI service as an array + + Methods = Array("Activate" _ + , "CreateBaseDocument" _ + , "CreateDocument" _ + , "Documents" _ + , "GetDocument" _ + , "Maximize" _ + , "Minimize" _ + , "OpenBaseDocument" _ + , "OpenDocument" _ + , "Resize" _ + , "RunCommand" _ + , "SetStatusbar" _ + , "ShowProgressBar" _ + , "WindowExists" _ + ) + +End Function ' ScriptForge.SF_UI.Methods + +REM ----------------------------------------------------------------------------- +Public Function OpenBaseDocument(Optional ByVal FileName As Variant _ + , Optional ByVal RegistrationName As Variant _ + , Optional ByVal MacroExecution As Variant _ + ) As Object +''' Open an existing LibreOffice Base document and return a SFDocuments.Document object +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' RegistrationName: the name of a registered database +''' It is ignored if FileName <> "" +''' MacroExecution: one of the MACROEXECxxx constants +''' Returns: +''' A SFDocuments.SF_Base object +''' Null if the opening failed, including when due to a user decision +''' Exceptions: +''' BASEDOCUMENTOPENERROR Wrong arguments +''' Examples: +''' Dim mBasec As Object, FSO As Object +''' Set myBase = ui.OpenBaseDocument("C:\Temp\myDB.odb", MacroExecution := ui.MACROEXECNEVER) + +Dim oOpen As Variant ' Return value +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext +Dim oComp As Object ' Loaded component com.sun.star.lang.XComponent +Dim sFile As String ' Alias for FileName +Dim iMacro As Integer ' Alias for MacroExecution +Const cstThisSub = "UI.OpenBaseDocument" +Const cstSubArgs = "[FileName=""""], [RegistrationName=""""], [MacroExecution=0|1|2]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oOpen = Nothing + +Check: + If IsMissing(FileName) Or IsEmpty(FileName) Then FileName = "" + If IsMissing(RegistrationName) Or IsEmpty(RegistrationName) Then RegistrationName = "" + If IsMissing(MacroExecution) Or IsEmpty(MacroExecution) Then MacroExecution = MACROEXECNORMAL + + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName", , True) Then GoTo Finally + If Not SF_Utils._Validate(RegistrationName, "RegistrationName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(MacroExecution, "MacroExecution", V_NUMERIC _ + , Array(MACROEXECNORMAL, MACROEXECNEVER, MACROEXECALWAYS)) Then GoTo Finally + End If + + ' Check the existence of FileName + If Len(FileName) = 0 Then ' FileName has precedence over RegistrationName + If Len(RegistrationName) = 0 Then GoTo CatchError + Set oDBContext = SF_Utils._GetUNOService("DatabaseContext") + If Not oDBContext.hasRegisteredDatabase(RegistrationName) Then GoTo CatchError + FileName = SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(RegistrationName)) + End If + If Not SF_FileSystem.FileExists(FileName) Then GoTo CatchError + +Try: + With com.sun.star.document.MacroExecMode + Select Case MacroExecution + Case 0 : iMacro = .USE_CONFIG + Case 1 : iMacro = .NEVER_EXECUTE + Case 2 : iMacro = .ALWAYS_EXECUTE_NO_WARN + End Select + End With + + vProperties = Array(SF_Utils._MakePropertyValue("MacroExecutionMode", iMacro)) + + sFile = SF_FileSystem._ConvertToUrl(FileName) + Set oComp = StarDesktop.loadComponentFromURL(sFile, "_blank", 0, vProperties) + If Not IsNull(oComp) Then Set oOpen = CreateScriptService("SFDocuments.Document", oComp) + +Finally: + Set OpenBaseDocument = oOpen + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", FileName, "RegistrationName", RegistrationName) + GoTo Finally +End Function ' ScriptForge.SF_UI.OpenBaseDocument + +REM ----------------------------------------------------------------------------- +Public Function OpenDocument(Optional ByVal FileName As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal ReadOnly As Variant _ + , Optional ByVal Hidden As Variant _ + , Optional ByVal MacroExecution As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Object +''' Open an existing LibreOffice document with the given options +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' Password: To use when the document is protected +''' If wrong or absent while the document is protected, the user will be prompted to enter a password +''' ReadOnly: Default = False +''' Hidden: if True, open in the background (default = False) +''' To use with caution: activation or closure can only happen programmatically +''' MacroExecution: one of the MACROEXECxxx constants +''' FilterName: the name of a filter that should be used for loading the document +''' If present, the filter must exist +''' FilterOptions: an optional string of options associated with the filter +''' Returns: +''' A SFDocuments.SF_Document object or one of its subclasses +''' Null if the opening failed, including when due to a user decision +''' Exceptions: +''' DOCUMENTOPENERROR Wrong arguments +''' Examples: +''' Dim myDoc As Object, FSO As Object +''' Set myDoc = ui.OpenDocument("C:\Temp\myFile.odt", MacroExecution := ui.MACROEXECNEVER) + +Dim oOpen As Variant ' Return value +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim oComp As Object ' Loaded component com.sun.star.lang.XComponent +Dim sFile As String ' Alias for FileName +Dim iMacro As Integer ' Alias for MacroExecution +Const cstThisSub = "UI.OpenDocument" +Const cstSubArgs = "FileName, [Password=""""], [ReadOnly=False], [Hidden=False], [MacroExecution=0|1|2], [FilterName=""""], [FilterOptions=""""]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oOpen = Nothing + +Check: + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(ReadOnly) Or IsEmpty(ReadOnly) Then ReadOnly = False + If IsMissing(Hidden) Or IsEmpty(Hidden) Then Hidden = False + If IsMissing(MacroExecution) Or IsEmpty(MacroExecution) Then MacroExecution = MACROEXECNORMAL + If IsMissing(FilterName) Or IsEmpty(FilterName) Then FilterName = "" + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = "" + + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(ReadOnly, "ReadOnly", V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Hidden, "Hidden", V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(MacroExecution, "MacroExecution", V_NUMERIC _ + , Array(MACROEXECNORMAL, MACROEXECNEVER, MACROEXECALWAYS)) Then GoTo Finally + If Not SF_Utils._Validate(FilterName, "FilterName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterOptions, "FilterOptions", V_STRING) Then GoTo Finally + End If + + ' Check the existence of FileName and FilterName + If Not SF_FileSystem.FileExists(FileName) Then GoTo CatchError + If Len(FilterName) > 0 Then + Set oFilterFactory = SF_Utils._GetUNOService("FilterFactory") + If Not oFilterFactory.hasByName(FilterName) Then GoTo CatchError + End If + +Try: + With com.sun.star.document.MacroExecMode + Select Case MacroExecution + Case 0 : iMacro = .USE_CONFIG + Case 1 : iMacro = .NEVER_EXECUTE + Case 2 : iMacro = .ALWAYS_EXECUTE_NO_WARN + End Select + End With + + vProperties = Array( _ + SF_Utils._MakePropertyValue("ReadOnly", ReadOnly) _ + , SF_Utils._MakePropertyValue("Hidden", Hidden) _ + , SF_Utils._MakePropertyValue("MacroExecutionMode", iMacro) _ + , SF_Utils._MakePropertyValue("FilterName", FilterName) _ + , SF_Utils._MakePropertyValue("FilterOptions", FilterOptions) _ + ) + If Len(Password) > 0 Then ' Password is to add only if <> "" !? + vProperties = SF_Array.Append(vProperties, SF_Utils._MakePropertyValue("Password", Password)) + End If + + sFile = SF_FileSystem._ConvertToUrl(FileName) + Set oComp = StarDesktop.loadComponentFromURL(sFile, "_blank", 0, vProperties) + If Not IsNull(oComp) Then Set oOpen = CreateScriptService("SFDocuments.Document", oComp) + +Finally: + Set OpenDocument = oOpen + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + SF_Exception.RaiseFatal(DOCUMENTOPENERROR, "FileName", FileName, "Password", Password, "FilterName", FilterName) + GoTo Finally +End Function ' ScriptForge.SF_UI.OpenDocument + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "ActiveWindow" _ + , "Height" _ + , "Width" _ + , "X" _ + , "Y" _ + ) + +End Function ' ScriptForge.SF_UI.Properties + +REM ----------------------------------------------------------------------------- +Public Sub Resize(Optional ByVal Left As Variant _ + , Optional ByVal Top As Variant _ + , Optional ByVal Width As Variant _ + , Optional ByVal Height As Variant _ + ) +''' Resizes and/or moves the active window. Negative arguments are ignored. +''' If the window was minimized or without arguments, it is restored +''' Args: +''' Left, Top: Distances from top and left edges of the screen +''' Width, Height: Dimensions of the window +''' Examples: +''' ui.Resize(10,,500) ' Top and Height are unchanged +''' ... + +Dim vWindow As Window ' A single component +Dim oContainer As Object ' com.sun.star.awt.XWindow +Dim iPosSize As Integer ' Computes which of the 4 arguments should be considered +Const cstThisSub = "UI.Resize" +Const cstSubArgs = "[Left], [Top], [Width], [Height]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Left) Or IsEmpty(Left) Then Left = -1 + If IsMissing(Top) Or IsEmpty(Top) Then Top = -1 + If IsMissing(Width) Or IsEmpty(Width) Then Width = -1 + If IsMissing(Height) Or IsEmpty(Height) Then Height = -1 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Left, "Left", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(Top, "Top", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(Width, "Width", V_NUMERIC) Then GoTo Finally + If Not SF_Utils._Validate(Height, "Height", V_NUMERIC) Then GoTo Finally + End If + +Try: + vWindow = SF_UI._IdentifyWindow(StarDesktop.CurrentComponent) + If Not IsNull(vWindow.Frame) Then + Set oContainer = vWindow.Frame.ContainerWindow + iPosSize = 0 + If Left >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If Top >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If Width > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH + If Height > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT + With oContainer + .IsMaximized = False + .IsMinimized = False + .setPosSize(Left, Top, Width, Height, iPosSize) + End With + End If + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_UI.Resize + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) +''' Run on the current window the given menu command. The command is executed with or without arguments +''' A few typical commands: +''' About, Delete, Edit, Undo, Copy, Paste, ... +''' Dozens can be found on next page: https://wiki.documentfoundation.org/Development/DispatchCommands +''' Args: +''' Command: Case-sensitive. The command itself is not checked. +''' If the command does not contain the ".uno:" prefix, it is added. +''' If nothing happens, then the command is probably wrong +''' Args: Pairs of arguments name (string), value (any) +''' Returns: +''' Examples: +''' ui.RunCommand("BasicIDEAppear", _ +''' "Document", "LibreOffice Macros & Dialogs", _ +''' "LibName", "ScriptForge", _ +''' "Name", "SF_Session", _ +''' "Line", 600) + +Dim oDispatch ' com.sun.star.frame.DispatchHelper +Dim vProps As Variant ' Array of PropertyValues +Dim vValue As Variant ' A single value argument +Dim sCommand As String ' Alias of Command +Dim i As Long +Const cstPrefix = ".uno:" + +Const cstThisSub = "UI.RunCommand" +Const cstSubArgs = "Command, [arg0Name, arg0Value], [arg1Name, arg1Value], ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Command, "Command", V_STRING) Then GoTo Finally + If Not SF_Utils._ValidateArray(Args, "Args", 1) Then GoTo Finally + For i = 0 To UBound(Args) - 1 Step 2 + If Not SF_Utils._Validate(Args(i), "Arg" & CStr(i/2) & "Name", V_STRING) Then GoTo Finally + Next i + End If + +Try: + ' Build array of property values + vProps = Array() + For i = 0 To UBound(Args) - 1 Step 2 + If IsEmpty(Args(i + 1)) Then vValue = Null Else vValue = Args(i + 1) + vProps = SF_Array.Append(vProps, SF_Utils._MakePropertyValue(Args(i), vValue)) + Next i + Set oDispatch = SF_Utils._GetUNOService("DispatchHelper") + If SF_String.StartsWith(Command, cstPrefix) Then sCommand = Command Else sCommand = cstPrefix & Command + oDispatch.executeDispatch(StarDesktop.ActiveFrame, sCommand, "", 0, vProps) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_UI.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "UI.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_UI.SetProperty + +REM ----------------------------------------------------------------------------- +Public Sub SetStatusbar(Optional ByVal Text As Variant _ + , Optional ByVal Percentage As Variant _ + ) +''' Display a text and a progressbar in the status bar of the active window +''' Any subsequent calls in the same macro run refer to the same status bar of the same window, +''' even if the window is not active anymore +''' A call without arguments resets the status bar to its normal state. +''' Args: +''' Text: the optional text to be displayed before the progress bar +''' Percentage: the optional degree of progress between 0 and 100 +''' Examples: +''' Dim i As Integer +''' For i = 0 To 100 +''' ui.SetStatusbar("Progress ...", i) +''' Wait 50 +''' Next i +''' ui.SetStatusbar + +Dim oComp As Object +Dim oControl As Object +Dim oStatusbar As Object +Const cstThisSub = "UI.SetStatusbar" +Const cstSubArgs = "[Text], [Percentage]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Text) Or IsEmpty(Text) Then Text = "" + If IsMissing(Percentage) Or IsEmpty(Percentage) Then Percentage = -1 + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Text, "Text", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Percentage, "Percentage", V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oStatusbar = _SF_.Statusbar + With oStatusbar + If IsNull(oStatusbar) Then ' Initial call + Set oComp = StarDesktop.CurrentComponent + If Not IsNull(oComp) Then + Set oControl = Nothing + If SF_Session.HasUnoProperty(oComp, "CurrentController") Then Set oControl = oComp.CurrentController + If Not IsNull(oControl) Then + If SF_Session.HasUnoMethod(oControl, "getStatusIndicator") Then oStatusbar = oControl.getStatusIndicator() + End If + End If + If Not IsNull(oStatusbar) Then + .start("", 100) + End If + End If + If Not IsNull(oStatusbar) Then + If Len(Text) = 0 And Percentage = -1 Then + .end() + Set oStatusbar = Nothing + Else + If Len(Text) > 0 Then .setText(Text) + If Percentage >= 0 And Percentage <= 100 Then .setValue(Percentage) + End If + End If + End With + +Finally: + Set _SF_.Statusbar = oStatusbar + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_UI.SetStatusbar + +REM ----------------------------------------------------------------------------- +Public Sub ShowProgressBar(Optional Title As Variant _ + , Optional ByVal Text As Variant _ + , Optional ByVal Percentage As Variant _ + , Optional ByRef _Context As Variant _ + ) +''' Display a non-modal dialog box. Specify its title, an explicatory text and the progress on a progressbar +''' A call without arguments erases the progress bar dialog. +''' The box will anyway vanish at the end of the macro run. +''' Args: +''' Title: the title appearing on top of the dialog box (Default = "ScriptForge") +''' Text: the optional text to be displayed above the progress bar (default = zero-length string) +''' Percentage: the degree of progress between 0 and 100. Default = 0 +''' _Context: from Python, the XComponentXontext (FOR INTERNAL USE ONLY) +''' Examples: +''' Dim i As Integer +''' For i = 0 To 100 +''' ui.ShowProgressBar(, "Progress ... " & i & "/100", i) +''' Wait 50 +''' Next i +''' ui.ShowProgressBar + +Dim bFirstCall As Boolean ' True at first invocation of method +Dim oDialog As Object ' SFDialogs.Dialog object +Dim oFixedText As Object ' SFDialogs.DialogControl object +Dim oProgressBar As Object ' SFDialogs.DialogControl object +Dim sTitle As String ' Alias of Title +Const cstThisSub = "UI.ShowProgressBar" +Const cstSubArgs = "[Title], [Text], [Percentage]" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Title) Or IsEmpty(Title) Then Title = "" + If IsMissing(Text) Or IsEmpty(Text) Then Text = "" + If IsMissing(Percentage) Or IsEmpty(Percentage) Then Percentage = -1 + If IsMissing(_Context) Or IsEmpty(_Context) Then _Context = Nothing + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(Title, "Title", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Text, "Text", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Percentage, "Percentage", V_NUMERIC) Then GoTo Finally + End If + +Try: + With _SF_ + Set oDialog = .ProgressBarDialog + Set oFixedText = .ProgressBarText + Set oProgressBar = .ProgressBarBar + End With + With oDialog + bFirstCall = ( IsNull(oDialog) ) + If Not bFirstCall Then bFirstCall = Not ._IsStillAlive(False) ' False to not raise an error + If bFirstCall Then Set oDialog = CreateScriptService("SFDialogs.Dialog", "GlobalScope", "ScriptForge", "dlgProgress", _Context) + + If Not IsNull(oDialog) Then + If Len(Title) = 0 And Len(Text) = 0 And Percentage = -1 Then + Set oDialog = .Dispose() + Else + .Caption = Iif(Len(Title) > 0, Title, "ScriptForge") + If bFirstCall Then + Set oFixedText = .Controls("ProgressText") + Set oProgressBar = .Controls("ProgressBar") + .Execute(Modal := False) + End If + If Len(Text) > 0 Then oFixedText.Caption = Text + oProgressBar.Value = Iif(Percentage >= 0 And Percentage <= 100, Percentage, 0) + End If + End If + End With + +Finally: + With _SF_ + Set .ProgressBarDialog = oDialog + Set .ProgressBarText = oFixedText + Set .ProgressBarBar = oProgressBar + End With + SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' ScriptForge.SF_UI.ShowProgressBar + +REM ----------------------------------------------------------------------------- +Public Function WindowExists(Optional ByVal WindowName As Variant) As Boolean +''' Returns True if the specified window exists +''' Args: +''' WindowName: see definitions +''' Returns: +''' True if the given window is found +''' Examples: +''' ui.WindowExists("C:\Me\My file.odt") + +Dim bWindowExists As Boolean ' Return value +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "UI.WindowExists" +Const cstSubArgs = "WindowName" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bWindowExists = False + +Check: + If IsMissing(WindowName) Or IsEmpty(WindowName) Then WindowName = "" + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._ValidateFile(WindowName, "WindowName") Then GoTo Finally + End If + +Try: + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + vWindow = SF_UI._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the arguments ? + If (Len(.WindowFileName) > 0 And .WindowFileName = SF_FileSystem.ConvertToUrl(WindowName)) _ + Or (Len(.WindowName) > 0 And .WindowName = WindowName) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = WindowName) Then + bWindowExists = True + Exit Do + End If + End With + Loop + +Finally: + WindowExists = bWindowExists + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_UI.WindowExists + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Sub _CloseProgressBar(Optional ByRef poEvent As Object) +''' Triggered by the Close button in the dlgProgress dialog +''' to simply close the dialog + + ShowProgressBar() ' Without arguments => close the dialog + +End Sub ' ScriptForge.SF_UI._CloseProgressBar + +REM ----------------------------------------------------------------------------- +Public Function _IdentifyWindow(ByRef poComponent As Object) As Object +''' Return a Window object (definition on top of module) based on component given as argument +''' Is a shortcut to explore the most relevant properties or objects bound to a UNO component + +Dim oWindow As Window ' Return value +Dim sImplementation As String ' Component's implementationname +Dim sIdentifier As String ' Component's identifier +Dim vArg As Variant ' One single item of the Args UNO property +Dim FSO As Object ' Alias for SF_FileSystem + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set _IdentifyWindow = Nothing + sImplementation = "" : sIdentifier = "" + + Set FSO = SF_FileSystem + With oWindow + Set .Frame = Nothing + Set .Component = Nothing + .WindowName = "" + .WindowTitle = "" + .WindowFileName = "" + .DocumentType = "" + If IsNull(poComponent) Then GoTo Finally + If SF_Session.HasUnoProperty(poComponent, "ImplementationName") Then sImplementation = poComponent.ImplementationName + If SF_Session.HasUnoProperty(poComponent, "Identifier") Then sIdentifier = poComponent.Identifier + Set .Component = poComponent + Select Case sImplementation + Case "com.sun.star.comp.basic.BasicIDE" + .WindowName = BASICIDE + Case "com.sun.star.comp.dba.ODatabaseDocument" ' No identifier + .WindowFileName = SF_Utils._GetPropertyValue(poComponent.Args, "URL") + If Len(.WindowFileName) > 0 Then .WindowName = FSO.GetName(FSO._ConvertFromUrl(.WindowFileName)) + .DocumentType = BASEDOCUMENT + Case "org.openoffice.comp.dbu.ODatasourceBrowser" + Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode + Case "org.openoffice.comp.dbu.ORelationDesign" + Case "com.sun.star.comp.sfx2.BackingComp" ' Welcome screen + Set .Frame = poComponent.Frame + .WindowName = WELCOMESCREEN + Case Else + If Len(sIdentifier) > 0 Then + ' Do not use URL : it contains the TemplateFile when new documents are created from a template + .WindowFileName = poComponent.Location + If Len(.WindowFileName) > 0 Then .WindowName = FSO.GetName(FSO._ConvertFromUrl(.WindowFileName)) + If SF_Session.HasUnoProperty(poComponent, "Title") Then .WindowTitle = poComponent.Title + Select Case sIdentifier + Case "com.sun.star.sdb.FormDesign" ' Form + Case "com.sun.star.sdb.TextReportDesign" ' Report + Case "com.sun.star.text.TextDocument" ' Writer + .DocumentType = WRITERDOCUMENT + Case "com.sun.star.sheet.SpreadsheetDocument" ' Calc + .DocumentType = CALCDOCUMENT + Case "com.sun.star.presentation.PresentationDocument" ' Impress + .DocumentType = IMPRESSDOCUMENT + Case "com.sun.star.drawing.DrawingDocument" ' Draw + .DocumentType = DRAWDOCUMENT + Case "com.sun.star.formula.FormulaProperties" ' Math + .DocumentType = MATHDOCUMENT + Case Else + End Select + End If + End Select + If IsNull(.Frame) Then + If Not IsNull(poComponent.CurrentController) Then Set .Frame = poComponent.CurrentController.Frame + End If + End With + +Finally: + Set _IdentifyWindow = oWindow + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_UI._IdentifyWindow + +REM ----------------------------------------------------------------------------- +Public Function _PosSize() As Object +''' Returns the PosSize structure of the active window + +Dim vWindow As Window ' A single component +Dim oContainer As Object ' com.sun.star.awt.XWindow +Dim oPosSize As Object ' com.sun.star.awt.Rectangle + + Set oPosSize = Nothing + +Try: + vWindow = SF_UI._IdentifyWindow(StarDesktop.CurrentComponent) + If Not IsNull(vWindow.Frame) Then + Set oContainer = vWindow.Frame.ContainerWindow + Set oPosSize = oContainer.getPosSize() + End If + +Finally: + Set _PosSize = oPosSize + Exit Function +End Function ' ScriptForge.SF_UI._PosSize + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the UI instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[UI]" + + _Repr = "[UI]" + +End Function ' ScriptForge.SF_UI._Repr + +REM ============================================ END OF SCRIPTFORGE.SF_UI + \ No newline at end of file diff --git a/wizards/source/scriptforge/SF_Utils.xba b/wizards/source/scriptforge/SF_Utils.xba new file mode 100644 index 000000000..91b703c46 --- /dev/null +++ b/wizards/source/scriptforge/SF_Utils.xba @@ -0,0 +1,1113 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Explicit +Option Private Module + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Utils +''' ======== +''' FOR INTERNAL USE ONLY +''' Groups all private functions used by the official modules +''' Declares the Global variable _SF_ +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ===================================================================== GLOBALS + +Global _SF_ As Variant ' SF_Root (Basic) object) + +''' ScriptForge version +Const SF_Version = "7.4" + +''' Standard symbolic names for VarTypes +' V_EMPTY = 0 +' V_NULL = 1 +' V_INTEGER = 2 +' V_LONG = 3 +' V_SINGLE = 4 +' V_DOUBLE = 5 +' V_CURRENCY = 6 +' V_DATE = 7 +' V_STRING = 8 +''' Additional symbolic names for VarTypes +Global Const V_OBJECT = 9 +Global Const V_BOOLEAN = 11 +Global Const V_VARIANT = 12 +Global Const V_BYTE = 17 +Global Const V_USHORT = 18 +Global Const V_ULONG = 19 +Global Const V_BIGINT = 35 +Global Const V_DECIMAL = 37 +Global Const V_ARRAY = 8192 +''' Fictive VarTypes +Global Const V_NUMERIC = 99 ' Synonym of any numeric value [returned by _VarTypeExt()] +Global Const V_NOTHING = 101 ' Object categories [returned by _VarTypeObj()] Null object +Global Const V_UNOOBJECT = 102 ' Uno object or Uno structure +Global Const V_SFOBJECT = 103 ' ScriptForge object: has ObjectType and ServiceName properties +Global Const V_BASICOBJECT = 104 ' User Basic object + +Type _ObjectDescriptor ' Returned by the _VarTypeObj() method + iVarType As Integer ' One of the V_NOTHING, V_xxxOBJECT constants + sObjectType As String ' Either "" or "com.sun.star..." or a ScriptForge object type (ex. "SF_SESSION" or "DICTIONARY") + sServiceName As String ' Either "" or the service name of a ScriptForge object type (ex. "ScriptForge.Exception"- +End Type + +REM ================================================================== EXCEPTIONS + +Const MISSINGARGERROR = "MISSINGARGERROR" ' A mandatory argument is missing +Const ARGUMENTERROR = "ARGUMENTERROR" ' An argument does not pass the _Validate() validation +Const ARRAYERROR = "ARRAYERROR" ' An argument does not pass the _ValidateArray() validation +Const FILEERROR = "FILEERROR" ' An argument does not pass the _ValidateFile() validation + +REM =========================================pvA==================== PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Public Function _CDateToIso(pvDate As Variant) As Variant +''' Returns a string representation of the given Basic date +''' Dates as strings are essential in property values, where Basic dates are evil + +Dim sIsoDate As Variant ' Return value + + If VarType(pvDate) = V_DATE Then + If Year(pvDate) < 1900 Then ' Time only + sIsoDate = Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) & ":" & Right("0" & Second(pvDate), 2) + ElseIf Hour(pvDate) + Minute(pvDate) + Second(pvDate) = 0 Then ' Date only + sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2) + Else + sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2) _ + & " " & Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) _ + & ":" & Right("0" & Second(pvDate), 2) + End If + Else + sIsoDate = pvDate + End If + + _CDateToIso = sIsoDate + +End Function ' ScriptForge.SF_Utils._CDateToIso + +REM ----------------------------------------------------------------------------- +Public Function _CDateToUnoDate(pvDate As Variant) As Variant +''' Returns a UNO com.sun.star.util.DateTime/Date/Time object depending on the given date +''' by using the appropriate CDateToUnoDateXxx builtin function +''' UNO dates are essential in property values, where Basic dates are evil + +Dim vUnoDate As Variant ' Return value + + If VarType(pvDate) = V_DATE Then + If Year(pvDate) < 1900 Then + vUnoDate = CDateToUnoTime(pvDate) + ElseIf Hour(pvDate) + Minute(pvDate) + Second(pvDate) = 0 Then + vUnoDate = CDateToUnoDate(pvDate) + Else + vUnoDate = CDateToUnoDateTime(pvDate) + End If + Else + vUnoDate = pvDate + End If + + _CDateToUnoDate = vUnoDate + +End Function ' ScriptForge.SF_Utils._CDateToUnoDate + +REM ----------------------------------------------------------------------------- +Public Function _CPropertyValue(ByRef pvValue As Variant) As Variant +''' Set a value of a correct type in a com.sun.star.beans.PropertyValue +''' Date BASIC variables give error. Change them to UNO types +''' Empty arrays should be replaced by Null + +Dim vValue As Variant ' Return value + + If VarType(pvValue) = V_DATE Then + vValue = SF_Utils._CDateToUnoDate(pvValue) + ElseIf IsArray(pvValue) Then + If UBound(pvValue, 1) < LBound(pvValue, 1) Then vValue = Null Else vValue = pvValue + Else + vValue = pvValue + End If + _CPropertyValue() = vValue + +End Function ' ScriptForge.SF_Utils._CPropertyValue + +REM ----------------------------------------------------------------------------- +Public Function _CStrToDate(ByRef pvStr As String) As Date +''' Attempt to convert the input string to a Date variable with the CDate builtin function +''' If not successful, returns conventionally -1 (29/12/1899) +''' Date patterns: YYYY-MM-DD, HH:MM:DD and YYYY-MM-DD HH:MM:DD + +Dim dDate As Date ' Return value +Const cstNoDate = -1 + + dDate = cstNoDate +Try: + On Local Error Resume Next + dDate = CDate(pvStr) + +Finally: + _CStrToDate = dDate + Exit Function +End Function ' ScriptForge.SF_Utils._CStrToDate + +REM ----------------------------------------------------------------------------- +Public Function _EnterFunction(ByVal psSub As String, Optional ByVal psArgs As String) +''' Called on top of each public function +''' Used to trace routine in/outs (debug mode) +''' and to allow the explicit mention of the user call which caused an error +''' Args: +''' psSub = the called Sub/Function/Property, usually something like "service.sub" +''' Return: True when psSub is called from a user script +''' Used to bypass the validation of the arguments when unnecessary + + If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session + If IsMissing(psArgs) Then psArgs = "" + With _SF_ + If .StackLevel = 0 Then + .MainFunction = psSub + .MainFunctionArgs = psArgs + _EnterFunction = True + Else + _EnterFunction = False + End If + .StackLevel = .StackLevel + 1 + If .DebugMode Then ._AddToConsole("==> " & psSub & "(" & .StackLevel & ")") + End With + +End Function ' ScriptForge.SF_Utils._EnterFunction + +REM ----------------------------------------------------------------------------- +Public Function _ErrorHandling(Optional ByVal pbErrorHandler As Boolean) As Boolean +''' Error handling is normally ON and can be set OFF for debugging purposes +''' Each user visible routine starts with a call to this function to enable/disable +''' standard handling of internal errors +''' Args: +''' pbErrorHandler = if present, set its value +''' Return: the current value of the error handler + + If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session + If Not IsMissing(pbErrorHandler) Then _SF_.ErrorHandler = pbErrorHandler + _ErrorHandling = _SF_.ErrorHandler + +End Function ' ScriptForge.SF_Utils._ErrorHandling + +REM ----------------------------------------------------------------------------- +Public Sub _ExitFunction(ByVal psSub As String) +''' Called in the Finally block of each public function +''' Manage ScriptForge internal aborts +''' Resets MainFunction (root) when exiting the method called by a user script +''' Used to trace routine in/outs (debug mode) +''' Args: +''' psSub = the called Sub/Function/Property, usually something like "service.sub" + + If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' Useful only when current module has been recompiled + With _SF_ + If Err > 0 Then + SF_Exception.RaiseAbort(psSub) + End If + If .StackLevel = 1 Then + .MainFunction = "" + .MainFunctionArgs = "" + End If + If .DebugMode Then ._AddToConsole("<== " & psSub & "(" & .StackLevel & ")") + If .StackLevel > 0 Then .StackLevel = .StackLevel - 1 + End With + +End Sub ' ScriptForge.SF_Utils._ExitFunction + +REM ----------------------------------------------------------------------------- +Public Sub _ExportScriptForgePOTFile(ByVal FileName As String) +''' Export the ScriptForge POT file related to its own user interface +''' Should be called only before issuing new ScriptForge releases only +''' Args: +''' FileName: the resulting file. If it exists, is overwritten without warning + +Dim sHeader As String ' The specific header to insert + + sHeader = "" _ + & "*********************************************************************\n" _ + & "*** The ScriptForge library and its associated libraries ***\n" _ + & "*** are part of the LibreOffice project. ***\n" _ + & "*********************************************************************\n" _ + & "\n" _ + & "ScriptForge Release " & SF_Version & "\n" _ + & "-----------------------" + +Try: + With _SF_ + If Not IsNull(.LocalizedInterface) Then .LocalizedInterface.Dispose() + ._LoadLocalizedInterface(psMode := "ADDTEXT") ' Force reload of labels from the code + .LocalizedInterface.ExportToPOTFile(FileName, Header := sHeader) + End With + +Finally: + Exit Sub +End Sub ' ScriptForge.SF_Utils._ExportScriptForgePOTFile + +REM ----------------------------------------------------------------------------- +Public Function _GetPropertyValue(ByRef pvArgs As Variant, ByVal psName As String) As Variant +''' Returns the Value corresponding to the given name +''' Args +''' pvArgs: a zero_based array of PropertyValues +''' psName: the comparison is not case-sensitive +''' Returns: +''' Zero-length string if not found + +Dim vValue As Variant ' Return value +Dim i As Long + + vValue = "" + If IsArray(pvArgs) Then + For i = LBound(pvArgs) To UBound(pvArgs) + If UCase(psName) = UCase(pvArgs(i).Name) Then + vValue = pvArgs(i).Value + Exit For + End If + Next i + End If + _GetPropertyValue = vValue + +End Function ' ScriptForge.SF_Utils._GetPropertyValue + +REM ----------------------------------------------------------------------------- +Public Function _GetRegistryKeyContent(ByVal psKeyName as string _ + , Optional pbForUpdate as Boolean _ + ) As Variant +''' Implement a ConfigurationProvider service +''' Derived from the Tools library +''' Args: +''' psKeyName: the name of the node in the configuration tree +''' pbForUpdate: default = False + +Dim oConfigProvider as Object ' com.sun.star.configuration.ConfigurationProvider +Dim vNodePath(0) as New com.sun.star.beans.PropertyValue +Dim sConfig As String ' One of next 2 constants +Const cstConfig = "com.sun.star.configuration.ConfigurationAccess" +Const cstConfigUpdate = "com.sun.star.configuration.ConfigurationUpdateAccess" + + Set oConfigProvider = _GetUNOService("ConfigurationProvider") + vNodePath(0).Name = "nodepath" + vNodePath(0).Value = psKeyName + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If pbForUpdate Then sConfig = cstConfigUpdate Else sConfig = cstConfig + + Set _GetRegistryKeyContent = oConfigProvider.createInstanceWithArguments(sConfig, vNodePath()) + +End Function ' ScriptForge.SF_Utils._GetRegistryKeyContent + +REM ----------------------------------------------------------------------------- +Private Function _GetSetting(ByVal psPreference As String, psProperty As String) As Variant +''' Find in the configuration a specific setting based on its location in the +''' settings registry + +Dim oConfigProvider As Object ' com.sun.star.configuration.ConfigurationProvider +Dim vNodePath As Variant ' Array of com.sun.star.beans.PropertyValue + + ' Derived from the Tools library + Set oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") + vNodePath = Array(SF_Utils._MakePropertyValue("nodepath", psPreference)) + + _GetSetting = oConfigProvider.createInstanceWithArguments( _ + "com.sun.star.configuration.ConfigurationAccess", vNodePath()).getByName(psProperty) + +End Function ' ScriptForge.SF_Utils._GetSetting + +REM ----------------------------------------------------------------------------- +Public Function _GetUNOService(ByVal psService As String _ + , Optional ByVal pvArg As Variant _ + ) As Object +''' Create a UNO service +''' Each service is called only once +''' Args: +''' psService: shortcut to service +''' pvArg: some services might require an argument + +Dim sLocale As String ' fr-BE f.i. +Dim oDefaultContext As Object + + Set _GetUNOService = Nothing + With _SF_ + Select Case psService + Case "BrowseNodeFactory" + Set oDefaultContext = GetDefaultContext() + If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.script.browse.theBrowseNodeFactory") + Case "CalendarImpl" + If IsEmpty(.CalendarImpl) Or IsNull(.CalendarImpl) Then + Set .CalendarImpl = CreateUnoService("com.sun.star.i18n.CalendarImpl") + End If + Set _GetUNOService = .CalendarImpl + Case "CharacterClass" + If IsEmpty(.CharacterClass) Or IsNull(.CharacterClass) Then + Set .CharacterClass = CreateUnoService("com.sun.star.i18n.CharacterClassification") + End If + Set _GetUNOService = .CharacterClass + Case "ConfigurationProvider" + If IsEmpty(.ConfigurationProvider) Or IsNull(.ConfigurationProvider) Then + Set .ConfigurationProvider = CreateUnoService("com.sun.star.configuration.ConfigurationProvider") + End If + Set _GetUNOService = .ConfigurationProvider + Case "CoreReflection" + If IsEmpty(.CoreReflection) Or IsNull(.CoreReflection) Then + Set .CoreReflection = CreateUnoService("com.sun.star.reflection.CoreReflection") + End If + Set _GetUNOService = .CoreReflection + Case "DatabaseContext" + If IsEmpty(.DatabaseContext) Or IsNull(.DatabaseContext) Then + Set .DatabaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + End If + Set _GetUNOService = .DatabaseContext + Case "DispatchHelper" + If IsEmpty(.DispatchHelper) Or IsNull(.DispatchHelper) Then + Set .DispatchHelper = CreateUnoService("com.sun.star.frame.DispatchHelper") + End If + Set _GetUNOService = .DispatchHelper + Case "FileAccess" + If IsEmpty(.FileAccess) Or IsNull(.FileAccess) Then + Set .FileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") + End If + Set _GetUNOService = .FileAccess + Case "FilePicker" + If IsEmpty(.FilePicker) Or IsNull(.FilePicker) Then + Set .FilePicker = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") + End If + Set _GetUNOService = .FilePicker + Case "FilterFactory" + If IsEmpty(.FilterFactory) Or IsNull(.FilterFactory) Then + Set .FilterFactory = CreateUnoService("com.sun.star.document.FilterFactory") + End If + Set _GetUNOService = .FilterFactory + Case "FolderPicker" + If IsEmpty(.FolderPicker) Or IsNull(.FolderPicker) Then + Set .FolderPicker = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker") + End If + Set _GetUNOService = .FolderPicker + Case "FormatLocale" + If IsEmpty(.FormatLocale) Or IsNull(.FormatLocale) Then + .FormatLocale = CreateUnoStruct("com.sun.star.lang.Locale") + ' 1st and 2nd chance + sLocale = SF_Utils._GetSetting("org.openoffice.Setup/L10N", "ooSetupSystemLocale") + If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale") + .FormatLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always + .FormatLocale.Country = Right(sLocale, 2) + End If + Set _GetUNOService = .FormatLocale + Case "FunctionAccess" + If IsEmpty(.FunctionAccess) Or IsNull(.FunctionAccess) Then + Set .FunctionAccess = CreateUnoService("com.sun.star.sheet.FunctionAccess") + End If + Set _GetUNOService = .FunctionAccess + Case "GraphicExportFilter" + If IsEmpty(.GraphicExportFilter) Or IsNull(.GraphicExportFilter) Then + Set .GraphicExportFilter = CreateUnoService("com.sun.star.drawing.GraphicExportFilter") + End If + Set _GetUNOService = .GraphicExportFilter + Case "Introspection" + If IsEmpty(.Introspection) Or IsNull(.Introspection) Then + Set .Introspection = CreateUnoService("com.sun.star.beans.Introspection") + End If + Set _GetUNOService = .Introspection + Case "LocaleData" + If IsEmpty(.LocaleData) Or IsNull(.LocaleData) Then + Set .LocaleData = CreateUnoService("com.sun.star.i18n.LocaleData") + End If + Set _GetUNOService = .LocaleData + Case "MacroExpander" + Set oDefaultContext = GetDefaultContext() + If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.util.theMacroExpander") + Case "MailService" + If IsEmpty(.MailService) Or IsNull(.MailService) Then + If GetGuiType = 1 Then ' Windows + Set .MailService = CreateUnoService("com.sun.star.system.SimpleSystemMail") + Else + Set .MailService = CreateUnoService("com.sun.star.system.SimpleCommandMail") + End If + End If + Set _GetUNOService = .MailService + Case "Number2Text" + If IsEmpty(.Number2Text) Or IsNull(.Number2Text) Then + Set .Number2Text = CreateUnoService("com.sun.star.linguistic2.NumberText") + End If + Set _GetUNOService = .Number2Text + Case "OfficeLocale" + If IsEmpty(.OfficeLocale) Or IsNull(.OfficeLocale) Then + .OfficeLocale = CreateUnoStruct("com.sun.star.lang.Locale") + ' 1st and 2nd chance + sLocale = SF_Utils._GetSetting("org.openoffice.Setup/L10N", "ooLocale") + If Len(sLocale) = 0 Then sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "UILocale") + .OfficeLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always + .OfficeLocale.Country = Right(sLocale, 2) + End If + Set _GetUNOService = .OfficeLocale + Case "PackageInformationProvider" + If IsEmpty(.PackageProvider) Or IsNull(.PackageProvider) Then + Set .PackageProvider = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider") + End If + Set _GetUNOService = .PackageProvider + Case "PathSettings" + If IsEmpty(.PathSettings) Or IsNull(.PathSettings) Then + Set .PathSettings = CreateUnoService("com.sun.star.util.PathSettings") + End If + Set _GetUNOService = .PathSettings + Case "PathSubstitution" + If IsEmpty(.PathSubstitution) Or IsNull(.PathSubstitution) Then + Set .PathSubstitution = CreateUnoService("com.sun.star.util.PathSubstitution") + End If + Set _GetUNOService = .PathSubstitution + Case "PrinterServer" + If IsEmpty(.PrinterServer) Or IsNull(.PrinterServer) Then + Set .PrinterServer = CreateUnoService("com.sun.star.awt.PrinterServer") + End If + Set _GetUNOService = .PrinterServer + Case "ScriptProvider" + If IsMissing(pvArg) Then pvArg = SF_Session.SCRIPTISAPPLICATION + Select Case LCase(pvArg) + Case SF_Session.SCRIPTISEMBEDDED ' Document + If Not IsNull(ThisComponent) Then Set _GetUNOService = ThisComponent.getScriptProvider() + Case Else + If IsEmpty(.ScriptProvider) Or IsNull(.ScriptProvider) Then + Set .ScriptProvider = _ + CreateUnoService("com.sun.star.script.provider.MasterScriptProviderFactory").createScriptProvider("") + End If + Set _GetUNOService = .ScriptProvider + End Select + Case "SearchOptions" + If IsEmpty(.SearchOptions) Or IsNull(.SearchOptions) Then + Set .SearchOptions = New com.sun.star.util.SearchOptions + With .SearchOptions + .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP + .searchFlag = 0 + End With + End If + Set _GetUNOService = .SearchOptions + Case "SystemLocale", "Locale" + If IsEmpty(.SystemLocale) Or IsNull(.SystemLocale) Then + .SystemLocale = CreateUnoStruct("com.sun.star.lang.Locale") + sLocale = SF_Utils._GetSetting("org.openoffice.System/L10N", "SystemLocale") + .SystemLocale.Language = Split(sLocale, "-")(0) ' Language is most often 2 chars long, but not always + .SystemLocale.Country = Right(sLocale, 2) + End If + Set _GetUNOService = .SystemLocale + Case "SystemShellExecute" + If IsEmpty(.SystemShellExecute) Or IsNull(.SystemShellExecute) Then + Set .SystemShellExecute = CreateUnoService("com.sun.star.system.SystemShellExecute") + End If + Set _GetUNOService = .SystemShellExecute + Case "TextSearch" + If IsEmpty(.TextSearch) Or IsNull(.TextSearch) Then + Set .TextSearch = CreateUnoService("com.sun.star.util.TextSearch") + End If + Set _GetUNOService = .TextSearch + Case "Toolkit" + If IsEmpty(.Toolkit) Or IsNull(.Toolkit) Then + Set .Toolkit = CreateUnoService("com.sun.star.awt.Toolkit") + End If + Set _GetUNOService = .Toolkit + Case "URLTransformer" + If IsEmpty(.URLTransformer) Or IsNull(.URLTransformer) Then + Set .URLTransformer = CreateUnoService("com.sun.star.util.URLTransformer") + End If + Set _GetUNOService = .URLTransformer + Case Else + End Select + End With + +End Function ' ScriptForge.SF_Utils._GetUNOService + +REM ----------------------------------------------------------------------------- +Public Sub _InitializeRoot(Optional ByVal pbForce As Boolean) +''' Initialize _SF_ as SF_Root basic object +''' Args: +''' pbForce = True forces the reinit (default = False) + + If IsMissing(pbForce) Then pbForce = False + If pbForce Then Set _SF_ = Nothing + If IsEmpty(_SF_) Or IsNull(_SF_) Then + Set _SF_ = New SF_Root + Set _SF_.[Me] = _SF_ + End If + +End Sub ' ScriptForge.SF_Utils._InitializeRoot + +REM ----------------------------------------------------------------------------- +Public Function _MakePropertyValue(ByVal psName As String _ + , ByRef pvValue As Variant _ + ) As com.sun.star.beans.PropertyValue +''' Create and return a new com.sun.star.beans.PropertyValue + +Dim oPropertyValue As New com.sun.star.beans.PropertyValue + + With oPropertyValue + .Name = psName + .Value = SF_Utils._CPropertyValue(pvValue) + End With + _MakePropertyValue() = oPropertyValue + +End Function ' ScriptForge.SF_Utils._MakePropertyValue + +REM ----------------------------------------------------------------------------- +Public Function _Repr(ByVal pvArg As Variant, Optional ByVal plMax As Long) As String +''' Convert pvArg into a readable string (truncated if length > plMax) +''' Args +''' pvArg: may be of any type +''' plMax: maximum length of the resulting string (default = 32K) + +Dim sArg As String ' Return value +Dim oObject As Object ' Alias of argument to avoid "Object variable not set" +Dim oObjectDesc As Object ' Object descriptor +Dim sLength As String ' String length as a string +Dim i As Long +Const cstBasicObject = "com.sun.star.script.NativeObjectWrapper" + +Const cstMaxLength = 2^15 - 1 ' 32767 +Const cstByteLength = 25 +Const cstEtc = " … " + + If IsMissing(plMax) Then plMax = cstMaxLength + If plMax = 0 Then plMax = cstMaxLength + If IsArray(pvArg) Then + sArg = SF_Array._Repr(pvArg) + Else + Select Case VarType(pvArg) + Case V_EMPTY : sArg = "[EMPTY]" + Case V_NULL : sArg = "[NULL]" + Case V_OBJECT + Set oObjectDesc = SF_Utils._VarTypeObj(pvArg) + With oObjectDesc + Select Case .iVarType + Case V_NOTHING : sArg = "[NOTHING]" + Case V_OBJECT, V_BASICOBJECT + sArg = "[OBJECT]" + Case V_UNOOBJECT : sArg = "[" & .sObjectType & "]" + Case V_SFOBJECT + If Left(.sObjectType, 3) = "SF_" Then ' Standard module + sArg = "[" & .sObjectType & "]" + Else ' Class module must have a _Repr() method + Set oObject = pvArg + sArg = oObject._Repr() + End If + End Select + End With + Case V_VARIANT : sArg = "[VARIANT]" + Case V_STRING + sArg = SF_String._Repr(pvArg) + Case V_BOOLEAN : sArg = Iif(pvArg, "[TRUE]", "[FALSE]") + Case V_BYTE : sArg = Right("00" & Hex(pvArg), 2) + Case V_SINGLE, V_DOUBLE, V_CURRENCY + sArg = Format(pvArg) + If InStr(1, sArg, "E", 1) = 0 Then sArg = Format(pvArg, "##0.0##") + sArg = Replace(sArg, ",", ".") 'Force decimal point + Case V_BIGINT : sArg = CStr(CLng(pvArg)) + Case V_DATE : sArg = _CDateToIso(pvArg) + Case Else : sArg = CStr(pvArg) + End Select + End If + If Len(sArg) > plMax Then + sLength = "(" & Len(sArg) & ")" + sArg = Left(sArg, plMax - Len(cstEtc) - Len(slength)) & cstEtc & sLength + End If + _Repr = sArg + +End Function ' ScriptForge.SF_Utils._Repr + +REM ----------------------------------------------------------------------------- +Private Function _ReprValues(Optional ByVal pvArgs As Variant _ + , Optional ByVal plMax As Long _ + ) As String +''' Convert an array of values to a comma-separated list of readable strings + +Dim sValues As String ' Return value +Dim sValue As String ' A single value +Dim vValue As Variant ' A single item in the argument +Dim i As Long ' Items counter +Const cstMax = 20 ' Maximum length of single string +Const cstContinue = "…" ' Unicode continuation char U+2026 + + _ReprValues = "" + If IsMissing(pvArgs) Then Exit Function + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) + sValues = "" + For i = 0 To UBound(pvArgs) + vValue = pvArgs(i) + If i < plMax Then + If VarType(vValue) = V_STRING Then sValue = """" & vValue & """" Else sValue = SF_Utils._Repr(vValue, cstMax) + If Len(sValues) = 0 Then sValues = sValue Else sValues = sValues & ", " & sValue + ElseIf i < UBound(pvArgs) Then + sValues = sValues & ", " & cstContinue + Exit For + End If + Next i + _ReprValues = sValues + +End Function ' ScriptForge.SF_Utils._ReprValues + +REM ----------------------------------------------------------------------------- +Public Function _SetPropertyValue(ByVal pvPropertyValue As Variant _ + , ByVal psName As String _ + , ByRef pvValue As Variant _ + ) As Variant +''' Return the 1st argument (passed by reference), which is an array of property values +''' If the property psName exists, update it with pvValue, otherwise create it on top of the returned array + +Dim oPropertyValue As New com.sun.star.beans.PropertyValue +Dim lIndex As Long ' Found entry +Dim vValue As Variant ' Alias of pvValue +Dim vProperties As Variant ' Alias of pvPropertyValue +Dim i As Long + + lIndex = -1 + vProperties = pvPropertyValue + For i = 0 To UBound(vProperties) + If vProperties(i).Name = psName Then + lIndex = i + Exit For + End If + Next i + If lIndex < 0 Then ' Not found + lIndex = UBound(vProperties) + 1 + ReDim Preserve vProperties(0 To lIndex) + Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue) + vProperties(lIndex) = oPropertyValue + vProperties = vProperties + Else ' psName exists already in array of property values + vProperties(lIndex).Value = SF_Utils._CPropertyValue(pvValue) + End If + + _SetPropertyValue = vProperties + +End Function ' ScriptForge.SF_Utils._SetPropertyValue + +REM ----------------------------------------------------------------------------- +Private Function _TypeNames(Optional ByVal pvArgs As Variant) As String +''' Converts the array of VarTypes to a comma-separated list of TypeNames + +Dim sTypes As String ' Return value +Dim sType As String ' A single type +Dim iType As Integer ' A single item of the argument + + _TypeNames = "" + If IsMissing(pvArgs) Then Exit Function + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) + sTypes = "" + For Each iType In pvArgs + Select Case iType + Case V_EMPTY : sType = "Empty" + Case V_NULL : sType = "Null" + Case V_INTEGER : sType = "Integer" + Case V_LONG : sType = "Long" + Case V_SINGLE : sType = "Single" + Case V_DOUBLE : sType = "Double" + Case V_CURRENCY : sType = "Currency" + Case V_DATE : sType = "Date" + Case V_STRING : sType = "String" + Case V_OBJECT : sType = "Object" + Case V_BOOLEAN : sType = "Boolean" + Case V_VARIANT : sType = "Variant" + Case V_DECIMAL : sType = "Decimal" + Case >= V_ARRAY : sType = "Array" + Case V_NUMERIC : sType = "Numeric" + End Select + If Len(sTypes) = 0 Then sTypes = sType Else sTypes = sTypes & ", " & sType + Next iType + _TypeNames = sTypes + +End Function ' ScriptForge.SF_Utils._TypeNames + +REM ----------------------------------------------------------------------------- +Public Function _Validate(Optional ByRef pvArgument As Variant _ + , ByVal psName As String _ + , Optional ByVal pvTypes As Variant _ + , Optional ByVal pvValues As Variant _ + , Optional ByVal pvRegex As Variant _ + , Optional ByVal pvObjectType As Variant _ + ) As Boolean +''' Validate the arguments set by user scripts +''' The arguments of the function define the validation rules +''' This function ignores arrays. Use _ValidateArray instead +''' Args: +''' pvArgument: the argument to (in)validate +''' psName: the documented name of the argument (can be inserted in an error message) +''' pvTypes: array of allowed VarTypes +''' pvValues: array of allowed values +''' pvRegex: regular expression to comply with +''' pvObjectType: mandatory Basic class +''' Return: True if validation OK +''' Otherwise an error is raised +''' Exceptions: +''' ARGUMENTERROR + +Dim iVarType As Integer ' Extended VarType of argument +Dim bValid As Boolean ' Returned value +Dim oObjectDescriptor As Object ' _ObjectDescriptor type +Const cstMaxLength = 256 ' Maximum length of readable value +Const cstMaxValues = 10 ' Maximum number of allowed items to list in an error message + + ' To avoid useless recursions, keep main function, only increase stack depth + _SF_.StackLevel = _SF_.StackLevel + 1 + On Local Error GoTo Finally ' Do never interrupt + +Try: + bValid = True + If IsMissing(pvArgument) Then GoTo CatchMissing + If IsMissing(pvRegex) Or IsEmpty(pvRegex) Then pvRegex = "" + If IsMissing(pvObjectType) Or IsEmpty(pvObjectType) Then pvObjectType = "" + iVarType = SF_Utils._VarTypeExt(pvArgument) + + ' Arrays NEVER pass validation + If iVarType >= V_ARRAY Then + bValid = False + Else + ' Check existence of argument + bValid = iVarType <> V_NULL And iVarType <> V_EMPTY + ' Check if argument's VarType is valid + If bValid And Not IsMissing(pvTypes) Then + If Not IsArray(pvTypes) Then bValid = ( pvTypes = iVarType ) Else bValid = SF_Array.Contains(pvTypes, iVarType) + End If + ' Check if argument's value is valid + If bValid And Not IsMissing(pvValues) Then + If Not IsArray(pvValues) Then pvValues = Array(pvValues) + bValid = SF_Array.Contains(pvValues, pvArgument, CaseSensitive := False) + End If + ' Check regular expression + If bValid And Len(pvRegex) > 0 And iVarType = V_STRING Then + If Len(pvArgument) > 0 Then bValid = SF_String.IsRegex(pvArgument, pvRegex, CaseSensitive := False) + End If + ' Check instance types + If bValid And Len(pvObjectType) > 0 And iVarType = V_OBJECT Then + 'Set oArgument = pvArgument + Set oObjectDescriptor = SF_Utils._VarTypeObj(pvArgument) + bValid = ( oObjectDescriptor.iVarType = V_SFOBJECT ) + If bValid Then bValid = ( oObjectDescriptor.sObjectType = pvObjectType ) + End If + End If + + If Not bValid Then + ''' Library: ScriptForge + ''' Service: Array + ''' Method: Contains + ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""] + ''' A serious error has been detected on argument SortOrder + ''' Rules: SortOrder is of type String + ''' SortOrder must contain one of next values: "ASC", "DESC", "" + ''' Actual value: "Ascending" + SF_Exception.RaiseFatal(ARGUMENTERROR _ + , SF_Utils._Repr(pvArgument, cstMaxLength), psName, SF_Utils._TypeNames(pvTypes) _ + , SF_Utils._ReprValues(pvValues, cstMaxValues), pvRegex, pvObjectType _ + ) + End If + +Finally: + _Validate = bValid + _SF_.StackLevel = _SF_.StackLevel - 1 + Exit Function +CatchMissing: + bValid = False + SF_Exception.RaiseFatal(MISSINGARGERROR, psName) + GoTo Finally +End Function ' ScriptForge.SF_Utils._Validate + +REM ----------------------------------------------------------------------------- +Public Function _ValidateArray(Optional ByRef pvArray As Variant _ + , ByVal psName As String _ + , Optional ByVal piDimensions As Integer _ + , Optional ByVal piType As Integer _ + , Optional ByVal pbNotNull As Boolean _ + ) As Boolean +''' Validate the (array) arguments set by user scripts +''' The arguments of the function define the validation rules +''' This function ignores non-arrays. Use _Validate instead +''' Args: +''' pvArray: the argument to (in)validate +''' psName: the documented name of the array (can be inserted in an error message) +''' piDimensions: the # of dimensions the array must have. 0 = Any (default) +''' piType: (default = -1, i.e. not applicable) +''' For 2D arrays, the 1st column is checked +''' 0 => all items must be any out of next types: string, date or numeric, +''' but homogeneously: all strings or all dates or all numeric +''' V_STRING or V_DATE or V_NUMERIC => that specific type is required +''' pbNotNull: piType must be >=0, otherwise ignored +''' If True: Empty, Null items are rejected +''' Return: True if validation OK +''' Otherwise an error is raised +''' Exceptions: +''' ARRAYERROR + +Dim iVarType As Integer ' VarType of argument +Dim vItem As Variant ' Array item +Dim iItemType As Integer ' VarType of individual items of argument +Dim iDims As Integer ' Number of dimensions of the argument +Dim bValid As Boolean ' Returned value +Dim iArrayType As Integer ' Static array type +Dim iFirstItemType As Integer ' Type of 1st non-null/empty item +Dim sType As String ' Allowed item types as a string +Dim i As Long +Const cstMaxLength = 256 ' Maximum length of readable value + + ' To avoid useless recursions, keep main function, only increase stack depth + + _SF_.StackLevel = _SF_.StackLevel + 1 + On Local Error GoTo Finally ' Do never interrupt + +Try: + bValid = True + If IsMissing(pvArray) Then GoTo CatchMissing + If IsMissing(piDimensions) Then piDimensions = 0 + If IsMissing(piType) Then piType = -1 + If IsMissing(pbNotNull) Then pbNotNull = False + iVarType = VarType(pvArray) + + ' Scalars NEVER pass validation + If iVarType < V_ARRAY Then + bValid = False + Else + ' Check dimensions + iDims = SF_Array.CountDims(pvArray) + If iDims > 2 Then bValid = False ' Only 1D and 2D arrays + If bValid And piDimensions > 0 Then + bValid = ( iDims = piDimensions Or (iDims = 0 And piDimensions = 1) ) ' Allow empty vectors + End If + ' Check VarType and Empty/Null status of the array items + If bValid And iDims = 1 And piType >= 0 Then + iArrayType = SF_Array._StaticType(pvArray) + If (piType = 0 And iArrayType > 0) Or (piType > 0 And iArrayType = piType) Then + ' If static array of the right VarType ..., OK + Else + ' Go through array and check individual items + iFirstItemType = -1 + For i = LBound(pvArray, 1) To UBound(pvArray, 1) + If iDims = 1 Then vItem = pvArray(i) Else vItem = pvArray(i, LBound(pvArray, 2)) + iItemType = SF_Utils._VarTypeExt(vItem) + If iItemType > V_NULL Then ' Exclude Empty and Null + ' Initialization at first non-null item + If iFirstItemType < 0 Then + iFirstItemType = iItemType + If piType > 0 Then bValid = ( iFirstItemType = piType ) Else bValid = SF_Array.Contains(Array(V_STRING, V_DATE, V_NUMERIC), iFirstItemType) + Else + bValid = (iItemType = iFirstItemType) + End If + Else + bValid = Not pbNotNull + End If + If Not bValid Then Exit For + Next i + End If + End If + End If + + If Not bValid Then + ''' Library: ScriptForge + ''' Service: Array + ''' Method: Contains + ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""|"ASC"|"DESC"] + ''' An error was detected on argument Array_1D + ''' Rules: Array_1D is of type Array + ''' Array_1D must have maximum 1 dimension + ''' Array_1D must have all elements of the same type: either String, Date or Numeric + ''' Actual value: (0:2, 0:3) + sType = "" + If piType = 0 Then + sType = "String, Date, Numeric" + ElseIf piType > 0 Then + sType = SF_Utils._TypeNames(piType) + End If + SF_Exception.RaiseFatal(ARRAYERROR _ + , SF_Utils._Repr(pvArray, cstMaxLength), psName, piDimensions, sType, pbNotNull) + End If + +Finally: + _ValidateArray = bValid + _SF_.StackLevel = _SF_.StackLevel - 1 + Exit Function +CatchMissing: + bValid = False + SF_Exception.RaiseFatal(MISSINGARGERROR, psName) + GoTo Finally +End Function ' ScriptForge.SF_Utils._ValidateArray + +REM ----------------------------------------------------------------------------- +Public Function _ValidateFile(Optional ByRef pvArgument As Variant _ + , ByVal psName As String _ + , Optional ByVal pbWildCards As Boolean _ + , Optional ByVal pbSpace As Boolean _ + ) +''' Validate the argument as a valid FileName +''' Args: +''' pvArgument: the argument to (in)validate +''' pbWildCards: if True, wildcard characters are accepted in the last component of the 1st argument +''' pbSpace: if True, the argument may be an empty string. Default = False +''' Return: True if validation OK +''' Otherwise an error is raised +''' Exceptions: +''' ARGUMENTERROR + +Dim iVarType As Integer ' VarType of argument +Dim sFile As String ' Alias for argument +Dim bValid As Boolean ' Returned value +Dim sFileNaming As String ' Alias of SF_FileSystem.FileNaming +Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement +Const cstMaxLength = 256 ' Maximum length of readable value + + ' To avoid useless recursions, keep main function, only increase stack depth + + _SF_.StackLevel = _SF_.StackLevel + 1 + On Local Error GoTo Finally ' Do never interrupt + +Try: + bValid = True + If IsMissing(pvArgument) Then GoTo CatchMissing + If IsMissing(pbWildCards) Then pbWildCards = False + If IsMissing(pbSpace) Then pbSpace = False + iVarType = VarType(pvArgument) + + ' Arrays NEVER pass validation + If iVarType >= V_ARRAY Then + bValid = False + Else + ' Argument must be a string containing a valid file name + bValid = ( iVarType = V_STRING ) + If bValid Then + bValid = ( Len(pvArgument) > 0 Or pbSpace ) + If bValid And Len(pvArgument) > 0 Then + ' Wildcards are replaced by arbitrary alpha characters + If pbWildCards Then + sFile = Replace(Replace(pvArgument, "?", "Z"), "*", "A") + Else + sFile = pvArgument + bValid = ( InStr(sFile, "?") + InStr(sFile, "*") = 0 ) + End If + ' Check file format without wildcards + If bValid Then + With SF_FileSystem + sFileNaming = .FileNaming + Select Case sFileNaming + Case "ANY" : bValid = SF_String.IsUrl(ConvertToUrl(sFile)) + Case "URL" : bValid = SF_String.IsUrl(sFile) + Case "SYS" : bValid = SF_String.IsFileName(sFile) + End Select + End With + End If + ' Check that wildcards are only present in last component + If bValid And pbWildCards Then + sFile = SF_FileSystem.GetParentFolderName(pvArgument) + bValid = ( InStr(sFile, "*") + InStr(sFile, "?") + InStr(sFile,"%3F") = 0 ) ' ConvertToUrl replaces ? by %3F + End If + End If + End If + End If + + If Not bValid Then + ''' Library: ScriptForge + ''' Service: FileSystem + ''' Method: CopyFile + ''' Arguments: Source, Destination + ''' A serious error has been detected on argument Source + ''' Rules: Source is of type String + ''' Source must be a valid file name expressed in operating system notation + ''' Source may contain one or more wildcard characters in its last component + ''' Actual value: /home/jean-*/SomeFile.odt + SF_Exception.RaiseFatal(FILEERROR _ + , SF_Utils._Repr(pvArgument, cstMaxLength), psName, pbWildCards) + End If + +Finally: + _ValidateFile = bValid + _SF_.StackLevel = _SF_.StackLevel - 1 + Exit Function +CatchMissing: + bValid = False + SF_Exception.RaiseFatal(MISSINGARGERROR, psName) + GoTo Finally +End Function ' ScriptForge.SF_Utils._ValidateFile + +REM ----------------------------------------------------------------------------- +Public Function _VarTypeExt(ByRef pvValue As Variant) As Integer +''' Return the VarType of the argument but all numeric types are aggregated into V_NUMERIC +''' Args: +''' pvValue: value to examine +''' Return: +''' The extended VarType + +Dim iType As Integer ' VarType of argument + + iType = VarType(pvValue) + Select Case iType + Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL + _VarTypeExt = V_NUMERIC + Case Else : _VarTypeExt = iType + End Select + +End Function ' ScriptForge.SF_Utils._VarTypeExt + +REM ----------------------------------------------------------------------------- +Public Function _VarTypeObj(ByRef pvValue As Variant) As Object +''' Inspect the argument that is supposed to be an Object +''' Return the internal type of object as one of the values +''' V_NOTHING Null object +''' V_UNOOBJECT Uno object or Uno structure +''' V_SFOBJECT ScriptForge object: has ObjectType and ServiceName properties +''' V_BASICOBJECT User Basic object +''' coupled with object type as a string ("com.sun.star..." or "SF_..." or "... ScriptForge class ...") +''' When the argument is not an Object, return the usual VarType() of the argument + +Dim oObjDesc As _ObjectDescriptor ' Return value +Dim oValue As Object ' Alias of pvValue used to avoid "Object variable not set" error +Dim sObjType As String ' The type of object is first derived as a string +Dim oReflection As Object ' com.sun.star.reflection.CoreReflection +Dim vClass As Variant ' com.sun.star.reflection.XIdlClass +Dim bUno As Boolean ' True when object recognized as UNO object + +Const cstBasicClass = "com.sun.star.script.NativeObjectWrapper" ' Way to recognize Basic objects + + On Local Error Resume Next ' Object type is established by trial and error + +Try: + With oObjDesc + .iVarType = VarType(pvValue) + .sObjectType = "" + .sServiceName = "" + bUno = False + If .iVarType = V_OBJECT Then + If IsNull(pvValue) Then + .iVarType = V_NOTHING + Else + Set oValue = pvValue + ' Try UNO type with usual ImplementationName property + .sObjectType = oValue.getImplementationName() + If .sObjectType = "" Then + ' Try UNO type with alternative CoreReflection trick + Set oReflection = SF_Utils._GetUNOService("CoreReflection") + vClass = oReflection.getType(oValue) + If vClass.TypeClass >= com.sun.star.uno.TypeClass.STRUCT Then + .sObjectType = vClass.Name + bUno = True + End If + Else + bUno = True + End If + ' Identify Basic objects + If .sObjectType = cstBasicClass Then + bUno = False + ' Try if the Basic object has an ObjectType property + .sObjectType = oValue.ObjectType + .sServiceName = oValue.ServiceName + End If + ' Derive the return value from the object type + Select Case True + Case Len(.sObjectType) = 0 ' Do nothing (return V_OBJECT) + Case .sObjectType = cstBasicClass : .iVarType = V_BASICOBJECT + Case bUno : .iVarType = V_UNOOBJECT + Case Else : .iVarType = V_SFOBJECT + End Select + End If + End If + End With + +Finally: + Set _VarTypeObj = oObjDesc + Exit Function +End Function ' ScriptForge.SF_Utils._VarTypeObj + +REM ================================================= END OF SCRIPTFORGE.SF_UTILS + \ No newline at end of file diff --git a/wizards/source/scriptforge/_CodingConventions.xba b/wizards/source/scriptforge/_CodingConventions.xba new file mode 100644 index 000000000..71fb42c77 --- /dev/null +++ b/wizards/source/scriptforge/_CodingConventions.xba @@ -0,0 +1,100 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' +' Conventions used in the coding of the *ScriptForge* library +' ----------------------------------------------------------- +''' +' Library and Modules +' =================== +' * Module names are all prefixed with "SF_". +' * The *Option Explicit* statement is mandatory in every module. +' * The *Option Private Module* statement is recommended in internal modules. +' * A standard header presenting the module/class is mandatory +' * An end of file (eof) comment line is mandatory +' * Every module lists the constants that are related to it and documented as return values, arguments, etc. +' They are defined as *Global Const*. +' The scope of global constants being limited to one single library, their invocation from user scripts shall be qualified. +' * The Basic reserved words are *Proper-Cased*. +''' +' Functions and Subroutines +' ========================= +' * LibreOffice ignores the Private/Public attribute in Functions or Subs declarations. +' Nevertheless the attribute must be present. +' Rules to recognize their scope are: +' * Public + name starts with a letter +' The Sub/Function belongs to the official ScriptForge API. +' As such it may be called from any user script. +' * Public + name starts with an underscore "_" +' The Sub/Function may be called only from within the ScriptForge library. +' As such it MUST NOT be called from another library or from a user script, +' as there is no guarantee about the arguments, the semantic or even the existence of that piece of code in a later release. +' * Private - The Sub/Function name must start with an underscore "_". +' The Sub/Function may be called only from the module in which it is located. +' * Functions and Subroutines belonging to the API (= "standard" functions/Subs) are defined in their module in alphabetical order. +' For class modules, all the properties precede the methods which precede the events. +' * Functions and Subroutines not belonging to the API are defined in their module in alphabetical order below the standard ones. +' * The return value of a function is always declared explicitly. +' * The parameters are always declared explicitly even if they're variants. +' * The Function and Sub declarations start at the 1st column of the line. +' * The End Function/Sub statement is followed by a comment reminding the name of the containing library.module and of the function or sub. +' If the Function/Sub is declared for the first time or modified in a release > initial public release, the actual release number is mentioned as well. +''' +' Variable declarations +' ===================== +' * Variable names use only alpha characters, the underscore and digits (no accented characters). +' Exceptionally, names of private variables may be embraced with `[` and `]` if `Option Compatible` is present. +' * The Global, Dim and Const statements always start in the first column of the line. +' * The type (*Dim ... As ...*, *Function ... As ...*) is always declared explicitly, even if the type is Variant. +' * Variables are *Proper-Cased*. They are always preceded by a lower-case letter indicating their type. +' With next exception: variables i, j, k, l, m and n must be declared as integers or longs. +' > b Boolean +' > d Date +' > v Variant +' > o Object +' > i Integer +' > l Long +' > s String +' Example: +' Dim sValue As String +' * Parameters are preceded by the letter *p* which itself precedes the single *typing letter*. +' In official methods, to match their published documentation, the *p* and the *typing letter* may be omitted. Like in: +' Private Function MyFunction(psValue As String) As Variant +' Public Function MyOfficialFunction(Value As String) As Variant +' * Global variables in the ScriptForge library are ALL preceded by an underscore "_" as NONE of them should be invoked from outside the library. +' * Constant values with a local scope are *Proper-Cased* and preceded by the letters *cst*. +' * Constants with a global scope are *UPPER-CASED*. +' Example: +' Global Const ACONSTANT = "This is a global constant" +' Function MyFunction(pocControl As Object, piValue) As Variant +' Dim iValue As Integer +' Const cstMyConstant = 3 +''' +' Indentation +' =========== +' Code shall be indented with TAB characters. +''' +' Goto/Gosub +' ========== +' The *GoSub* … *Return* statement is forbidden. +' The *GoTo* statement is forbidden. +' However *GoTo* is highly recommended for *error* and *exception* handling. +''' +' Comments (english only) +' ======== +' * Every public routine should be documented with a python-like "docstring": +' 1. Role of Sub/Function +' 2. List of arguments, mandatory/optional, role +' 3. Returned value(s) type and meaning +' 4. Examples when useful +' 5. Eventual specific exception codes +' * The "docstring" comments shall be marked by a triple (single) quote character at the beginning of the line +' * Meaningful variables shall be declared one per line. Comment on same line. +' * Comments about a code block should be left indented. +' If it concerns only the next line, no indent required (may also be put at the end of the line). +''' + \ No newline at end of file diff --git a/wizards/source/scriptforge/_ModuleModel.xba b/wizards/source/scriptforge/_ModuleModel.xba new file mode 100644 index 000000000..135eced58 --- /dev/null +++ b/wizards/source/scriptforge/_ModuleModel.xba @@ -0,0 +1,221 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule +'Option Private Module + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' ModuleModel (aka SF_Model) +''' =========== +''' Illustration of how the ScriptForge modules are structured +''' Copy and paste this code in an empty Basic module to start a new service +''' Comment in, comment out, erase what you want, but at the end respect the overall structure +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +''' FAKENEWSERROR + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object ' Should be initialized immediately after the New statement + ' Dim obj As Object : Set obj = New SF_Model + ' Set obj.[Me] = obj +Private [_Parent] As Object ' To keep trace of the instance having created a sub-instance + ' Set obj._Parent = [Me] +Private ObjectType As String ' Must be UNIQUE + +REM ============================================================ MODULE CONSTANTS + +Private Const SOMECONSTANT = 1 + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "MODEL" +End Sub ' ScriptForge.SF_Model Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' ScriptForge.SF_Model Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' ScriptForge.SF_Model Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get MyProperty() As Boolean +''' Returns True or False +''' Example: +''' myModel.MyProperty + + MyProperty = _PropertyGet("MyProperty") + +End Property ' ScriptForge.SF_Model.MyProperty + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "Model.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' ScriptForge.SF_Model.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "MyFunction" _ + , "etc" _ + ) + +End Function ' ScriptForge.SF_Model.Methods + +REM ----------------------------------------------------------------------------- +Public Function MyFunction(Optional ByVal Arg1 As Variant _ + , Optional ByVal Arg2 As Variant _ + ) As Variant +''' Fictive function that concatenates Arg1 Arg2 times +''' Args: +''' Arg1 String Text +''' Arg2 Numeric Number of times (default = 2) +''' Returns: +''' The new string +''' Exceptions: +''' FAKENEWSERROR +''' Examples: +''' MyFunction("value1") returns "value1value1" + +Dim sOutput As String ' Output buffer +Dim i As Integer +Const cstThisSub = "Model.myFunction" +Const cstSubArgs = "Arg1, [Arg2=2]" + + ' _ErrorHandling returns False when, for debugging, the standard error handling is preferred + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + myFunction = "" + +Check: + If IsMissing(Arg2) Then Arg2 = 2 + ' _EnterFunction returns True when current method is invoked from a user script + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + ' Check Arg1 is a string and Arg2 is a number. + ' Validation rules for scalars and arrays are described in SF_Utils + If Not SF_Utils._Validate(Arg1, "Arg1", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Arg2, "Arg2", V_NUMERIC) Then GoTo Finally + ' Fatal error ? + If Arg2 < 0 Then GoTo CatchFake + End If + +Try: + sOutput = "" + For i = 0 To Arg2 + sOutput = sOutput & Arg1 + Next i + myFunction = sOutput + +Finally: + ' _ExitFunction manages internal (On Local) errors + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchFake: + SF_Exception.RaiseFatal("FAKENEWSERROR", cstThisSub) + GoTo Finally +End Function ' ScriptForge.SF_Model.myFunction + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Model class as an array + + Properties = Array( _ + "MyProperty" _ + , "etc" _ + ) + +End Function ' ScriptForge.SF_Model.Properties + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SF_Model.get" & psProperty + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case psProperty + Case "MyProperty" + _PropertyGet = TBD + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' ScriptForge.SF_Model._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[MODEL]: A readable string" + + _Repr = "[MODEL]: A readable string" + +End Function ' ScriptForge.SF_Model._Repr + +REM ============================================ END OF SCRIPTFORGE.SF_MODEL + \ No newline at end of file diff --git a/wizards/source/scriptforge/__License.xba b/wizards/source/scriptforge/__License.xba new file mode 100644 index 000000000..a81752525 --- /dev/null +++ b/wizards/source/scriptforge/__License.xba @@ -0,0 +1,25 @@ + + + +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/scriptforge/dialog.xlb b/wizards/source/scriptforge/dialog.xlb new file mode 100644 index 000000000..7b54d071c --- /dev/null +++ b/wizards/source/scriptforge/dialog.xlb @@ -0,0 +1,6 @@ + + + + + + \ No newline at end of file diff --git a/wizards/source/scriptforge/dlgConsole.xdl b/wizards/source/scriptforge/dlgConsole.xdl new file mode 100644 index 000000000..64009f571 --- /dev/null +++ b/wizards/source/scriptforge/dlgConsole.xdl @@ -0,0 +1,14 @@ + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/scriptforge/dlgProgress.xdl b/wizards/source/scriptforge/dlgProgress.xdl new file mode 100644 index 000000000..9d5f2776d --- /dev/null +++ b/wizards/source/scriptforge/dlgProgress.xdl @@ -0,0 +1,11 @@ + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/scriptforge/po/ScriptForge.pot b/wizards/source/scriptforge/po/ScriptForge.pot new file mode 100644 index 000000000..248d800c0 --- /dev/null +++ b/wizards/source/scriptforge/po/ScriptForge.pot @@ -0,0 +1,975 @@ +# +# This pristine POT file has been generated by LibreOffice/ScriptForge +# Full documentation is available on https://help.libreoffice.org/ +# +# ********************************************************************* +# *** The ScriptForge library and its associated libraries *** +# *** are part of the LibreOffice project. *** +# ********************************************************************* +# +# ScriptForge Release 7.4 +# ----------------------- +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: https://bugs.libreoffice.org/enter_bug.cgi?product=LibreOffice&bug_status=UNCONFIRMED&component=UI\n" +"POT-Creation-Date: 2022-05-04 18:07:20\n" +"PO-Revision-Date: YYYY-MM-DD HH:MM:SS\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"Language: en_US\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=n > 1;\n" +"X-Generator: LibreOffice - ScriptForge\n" +"X-Accelerator-Marker: ~\n" + +#. Title in error message box +#. %1: an error number +#, kde-format +msgctxt "ERRORNUMBER" +msgid "Error %1" +msgstr "" + +#. Error message box +#. %1: a line number +#, kde-format +msgctxt "ERRORLOCATION" +msgid "Location : %1" +msgstr "" + +#. Logfile record +#, kde-format +msgctxt "LONGERRORDESC" +msgid "Error %1 - Location = %2 - Description = %3" +msgstr "" + +#. Any blocking error message +msgctxt "STOPEXECUTION" +msgid "THE EXECUTION IS CANCELLED." +msgstr "" + +#. Any blocking error message +#. %1: a method name +#, kde-format +msgctxt "NEEDMOREHELP" +msgid "Do you want to receive more information about the '%1' method ?" +msgstr "" + +#. SF_Exception.RaiseAbort error message +msgctxt "INTERNALERROR" +msgid "" +"The ScriptForge library has crashed. The reason is unknown.\n" +"Maybe a bug that could be reported on\n" +" https://bugs.documentfoundation.org/\n" +"\n" +"More details : \n" +"\n" +"" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: probably ScriptForge +#. %2: service or module name +#. %3: property or method name where the error occurred +#, kde-format +msgctxt "VALIDATESOURCE" +msgid "" +"Library : %1\n" +"Service : %2\n" +"Method : %3" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: list of arguments of the method +#, kde-format +msgctxt "VALIDATEARGS" +msgid "Arguments: %1" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEERROR" +msgid "A serious error has been detected in your code on argument : « %1 »." +msgstr "" + +#. SF_Utils.Validate error message +msgctxt "VALIDATIONRULES" +msgid " Validation rules :" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: Comma separated list of allowed types +#, kde-format +msgctxt "VALIDATETYPES" +msgid " « %1 » must have next type (or one of next types) : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: Comma separated list of allowed values +#, kde-format +msgctxt "VALIDATEVALUES" +msgid " « %1 » must contain one of next values : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: A regular expression +#, kde-format +msgctxt "VALIDATEREGEX" +msgid " « %1 » must match next regular expression : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: The name of a Basic class +#, kde-format +msgctxt "VALIDATECLASS" +msgid " « %1 » must be a Basic object of class : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: The value of the argument as a string +#, kde-format +msgctxt "VALIDATEACTUAL" +msgid "The actual value of « %1 » is : '%2'" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEMISSING" +msgid "The « %1 » argument is mandatory, yet it is missing." +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEARRAY" +msgid " « %1 » must be an array." +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. %2: Number of dimensions of the array +#, kde-format +msgctxt "VALIDATEDIMS" +msgid " « %1 » must have exactly %2 dimension(s)." +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. %2: Either one single type or 'String, Date, Numeric' +#, kde-format +msgctxt "VALIDATEALLTYPES" +msgid " « %1 » must have all elements of the same type : %2" +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. NULL and EMPTY should not be translated +#, kde-format +msgctxt "VALIDATENOTNULL" +msgid " « %1 » must not contain any NULL or EMPTY elements." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. 'String' should not be translated +#, kde-format +msgctxt "VALIDATEFILE" +msgid " « %1 » must be of type String." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEFILESYS" +msgid "" +" « %1 » must be a valid file or folder name expressed in the " +"operating system native notation." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. 'URL' should not be translated +#, kde-format +msgctxt "VALIDATEFILEURL" +msgid "" +" « %1 » must be a valid file or folder name expressed in the " +"portable URL notation." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEFILEANY" +msgid " « %1 » must be a valid file or folder name." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. '(?, *)' is to be left as is +#, kde-format +msgctxt "VALIDATEWILDCARD" +msgid "" +" « %1 » may contain one or more wildcard characters (?, *) in " +"its last path component only." +msgstr "" + +#. SF_Array.RangeInit error message +#. %1, %2, %3: Numeric values +#. 'From', 'UpTo', 'ByStep' should not be translated +#, kde-format +msgctxt "ARRAYSEQUENCE" +msgid "" +"The respective values of 'From', 'UpTo' and 'ByStep' are incoherent.\n" +"\n" +" « From » = %1\n" +" « UpTo » = %2\n" +" « ByStep » = %3" +msgstr "" + +#. SF_Array.AppendColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_2D' should not be translated +#, kde-format +msgctxt "ARRAYINSERT" +msgid "" +"The array and the vector to insert have incompatible sizes.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" +msgstr "" + +#. SF_Array.ExtractColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_2D' should not be translated +#, kde-format +msgctxt "ARRAYINDEX1" +msgid "" +"The given index does not fit within the bounds of the array.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" +msgstr "" + +#. SF_Array.ExtractColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_1D', 'From' and 'UpTo' should not be translated +#, kde-format +msgctxt "ARRAYINDEX2" +msgid "" +"The given slice limits do not fit within the bounds of the array.\n" +"\n" +" « Array_1D » = %1\n" +" « From » = %2\n" +" « UpTo » = %3" +msgstr "" + +#. SF_Array.ImportFromCSVFile error message +#. %1: a file name +#. %2: numeric +#. %3: a long string +#, kde-format +msgctxt "CSVPARSING" +msgid "" +"The given file could not be parsed as a valid CSV file.\n" +"\n" +" « File name » = %1\n" +" Line number = %2\n" +" Content = %3" +msgstr "" + +#. SF_Dictionary Add/ReplaceKey error message +#. %1: An identifier%2: a (potentially long) string +#, kde-format +msgctxt "DUPLICATEKEY" +msgid "" +"The insertion of a new key into a dictionary failed because the key " +"already exists.\n" +"Note that the comparison between keys is NOT case-sensitive.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Dictionary Remove/ReplaceKey/ReplaceItem error message +#. %1: An identifier%2: a (potentially long) string +#, kde-format +msgctxt "UNKNOWNKEY" +msgid "" +"The requested key does not exist in the dictionary.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Dictionary Add/ReplaceKey error message +#. +msgctxt "INVALIDKEY" +msgid "" +"The insertion or the update of an entry into a dictionary failed " +"because the given key contains only spaces." +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "UNKNOWNFILE" +msgid "" +"The given file could not be found on your system.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A folder name +#, kde-format +msgctxt "UNKNOWNFOLDER" +msgid "" +"The given folder could not be found on your system.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "NOTAFILE" +msgid "" +"« %1 » contains the name of an existing folder, not that of a file.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A folder name +#, kde-format +msgctxt "NOTAFOLDER" +msgid "" +"« %1 » contains the name of an existing file, not that of a folder.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/... error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "OVERWRITE" +msgid "" +"You tried to create a new file which already exists. Overwriting it " +"has been rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "READONLY" +msgid "" +"Copying or moving a file to a destination which has its read-only " +"attribute set, or deleting such a file or folder is forbidden.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file or folder name with wildcards +#, kde-format +msgctxt "NOFILEMATCH" +msgid "" +"When « %1 » contains wildcards. at least one file or folder must " +"match the given filter. Otherwise the operation is rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem CreateFolder error message +#. %1: An identifier +#. %2: A file or folder name +#, kde-format +msgctxt "FOLDERCREATION" +msgid "" +"« %1 » contains the name of an existing file or an existing folder. " +"The operation is rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Services.CreateScriptService error message +#. %1: An identifier +#. %2: A string +#. %3: A Basic library name +#. %4: A service (1 word) name +#, kde-format +msgctxt "UNKNOWNSERVICE" +msgid "" +"No service named '%4' has been registered for the library '%3'.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Services.CreateScriptService error message +#. %1: An identifier +#. %2: A string +#. %3: A Basic library name +#, kde-format +msgctxt "SERVICESNOTLOADED" +msgid "" +"The library '%3' and its services could not been loaded.\n" +"The reason is unknown.\n" +"However, checking the '%3.SF_Services.RegisterScriptServices()' " +"function and its return value can be a good starting point.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Session.ExecuteCalcFunction error message +#. 'Calc' should not be translated +#, kde-format +msgctxt "CALCFUNC" +msgid "" +"The Calc '%1' function encountered an error. Either the given " +"function does not exist or its arguments are invalid." +msgstr "" + +#. SF_Session._GetScript error message +#. %1: 'Basic' or 'Python' +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#. %5: A string +#, kde-format +msgctxt "NOSCRIPT" +msgid "" +"The requested %1 script could not be located in the given libraries " +"and modules.\n" +"« %2 » = %3\n" +"« %4 » = %5" +msgstr "" + +#. SF_Session.ExecuteBasicScript error message +#. %1: An identifier +#. %2: A string +#. %3: A (long) string +#, kde-format +msgctxt "SCRIPTEXEC" +msgid "" +"An exception occurred during the execution of the Basic script.\n" +"Cause: %3\n" +"« %1 » = %2" +msgstr "" + +#. SF_Session.SendMail error message +#. %1 = a mail address +#, kde-format +msgctxt "WRONGEMAIL" +msgid "" +"One of the email addresses has been found invalid.\n" +"Invalid mail = « %1 »" +msgstr "" + +#. SF_Session.SendMail error message +msgctxt "SENDMAIL" +msgid "" +"The message could not be sent due to a system error.\n" +"A possible cause is that LibreOffice could not find any mail client." +msgstr "" + +#. SF_TextStream._IsFileOpen error message +#. %1: A file name +#, kde-format +msgctxt "FILENOTOPEN" +msgid "" +"The requested file operation could not be executed because the file " +"was closed previously.\n" +"\n" +"File name = '%1'" +msgstr "" + +#. SF_TextStream._IsFileOpen error message +#. %1: A file name +#. %2: READ, WRITE or APPEND +#, kde-format +msgctxt "FILEOPENMODE" +msgid "" +"The requested file operation could not be executed because it is " +"incompatible with the mode in which the file was opened.\n" +"\n" +"File name = '%1'\n" +"Open mode = %2" +msgstr "" + +#. SF_TextStream.ReadLine/ReadAll/SkipLine error message +#. %1: A file name +#, kde-format +msgctxt "ENDOFFILE" +msgid "" +"The requested file read operation could not be completed because an " +"unexpected end-of-file was encountered.\n" +"\n" +"File name = '%1'" +msgstr "" + +#. SF_UI.GetDocument error message +#. %1: An identifier +#. %2: A string +#, kde-format +msgctxt "DOCUMENT" +msgid "" +"The requested document could not be found.\n" +"\n" +"%1 = '%2'" +msgstr "" + +#. SF_UI.GetDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#, kde-format +msgctxt "DOCUMENTCREATION" +msgid "" +"The creation of a new document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the document type is unknown, or no template file was given,\n" +"or the given template file was not found on your system.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" +msgstr "" + +#. SF_UI.OpenDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#. %5: An identifier +#. %6: A string +#, kde-format +msgctxt "DOCUMENTOPEN" +msgid "" +"The opening of the document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the file does not exist, or the password is wrong, or the " +"given filter is invalid.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'\n" +"%5 = '%6'" +msgstr "" + +#. SF_UI.OpenDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#, kde-format +msgctxt "BASEDOCUMENTOPEN" +msgid "" +"The opening of the Base document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the file does not exist, or the file is not registered under " +"the given name.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" +msgstr "" + +#. SF_Document._IsStillAlive error message +#. %1: A file name +#, kde-format +msgctxt "DOCUMENTDEAD" +msgid "" +"The requested action could not be executed because the document was " +"closed inadvertently.\n" +"\n" +"The concerned document is '%1'" +msgstr "" + +#. SF_Document.SaveAs error message +#. %1: An identifier +#. %2: A file name +#. +#, kde-format +msgctxt "DOCUMENTSAVE" +msgid "" +"The document could not be saved.\n" +"Either the document has been opened read-only, or the destination " +"file has a read-only attribute set, or the file where to save to is " +"undefined.\n" +"\n" +"%1 = '%2'" +msgstr "" + +#. SF_Document.SaveAs error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. %5: An identifier +#. %6: A string +#, kde-format +msgctxt "DOCUMENTSAVEAS" +msgid "" +"The document could not be saved.\n" +"Either the document must not be overwritten, or the destination file " +"has a read-only attribute set, or the given filter is invalid.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4\n" +"%5 = '%6'" +msgstr "" + +#. SF_Document any update +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "DOCUMENTREADONLY" +msgid "" +"You tried to edit a document which is not modifiable. The document " +"has not been changed.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Base GetDatabase +#. %1: An identifier +#. %2: A user name +#. %3: An identifier +#. %4: A password +#. %5: A file name +#, kde-format +msgctxt "DBCONNECT" +msgid "" +"The database related to the actual Base document could not be " +"retrieved.\n" +"Check the connection/login parameters.\n" +"\n" +"« %1 » = '%2'\n" +"« %3 » = '%4'\n" +"« Document » = %5" +msgstr "" + +#. SF_Calc _ParseAddress (sheet) +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "CALCADDRESS1" +msgid "" +"The given address does not correspond with a valid sheet name.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" + +#. SF_Calc _ParseAddress (range) +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "CALCADDRESS2" +msgid "" +"The given address does not correspond with a valid range of cells.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" + +#. SF_Calc InsertSheet +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "DUPLICATESHEET" +msgid "" +"There exists already in the document a sheet with the same name.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" + +#. SF_Calc Offset +#. %1: An identifier +#. %2: A Calc reference +#. %3: An identifier +#. %4: A number +#. %5: An identifier +#. %6: A number +#. %7: An identifier +#. %8: A number +#. %9: An identifier +#. %10: A number +#. %11: An identifier +#. %12: A file name +#, kde-format +msgctxt "OFFSETADDRESS" +msgid "" +"The computed range falls beyond the sheet boundaries or is " +"meaningless.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8\n" +"« %9 » = %10\n" +"« %11 » = %12" +msgstr "" + +#. SF_Calc CreateChart +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#. %5: An identifier +#. %6: A file name +#, kde-format +msgctxt "DUPLICATECHART" +msgid "" +"A chart with the same name exists already in the sheet.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"" +msgstr "" + +#. SF_Calc.ExportRangeToFile error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. +#, kde-format +msgctxt "RANGEEXPORT" +msgid "" +"The given range could not be exported.\n" +"Either the destination file must not be overwritten, or it has a " +"read-only attribute set.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4" +msgstr "" + +#. SF_Chart.ExportToFile error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. +#, kde-format +msgctxt "CHARTEXPORT" +msgid "" +"The chart could not be exported.\n" +"Either the destination file must not be overwritten, or it has a " +"read-only attribute set.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4" +msgstr "" + +#. SF_Dialog._IsStillAlive error message +#. %1: An identifier%2: A file name +#, kde-format +msgctxt "FORMDEAD" +msgid "" +"The requested action could not be executed because the form is not " +"open or the document was closed inadvertently.\n" +"\n" +"The concerned form is '%1' in document '%2'." +msgstr "" + +#. SF_Form determination +#. %1: A number +#. %2: A sheet name +#. %3: A file name +#, kde-format +msgctxt "CALCFORMNOTFOUND" +msgid "" +"The requested form could not be found in the Calc sheet. The given " +"index is off-limits.\n" +"\n" +"The concerned Calc document is '%3'.\n" +"\n" +"The name of the sheet = '%2'\n" +"The index = %1." +msgstr "" + +#. SF_Form determination +#. %1: A number +#. %2: A file name +#, kde-format +msgctxt "WRITERFORMNOTFOUND" +msgid "" +"The requested form could not be found in the Writer document. The " +"given index is off-limits.\n" +"\n" +"The concerned Writer document is '%2'.\n" +"\n" +"The index = %1." +msgstr "" + +#. SF_Form determination +#. %1: A number +#. %2: A string +#. %3: A file name +#, kde-format +msgctxt "BASEFORMNOTFOUND" +msgid "" +"The requested form could not be found in the form document '%2'. The " +"given index is off-limits.\n" +"\n" +"The concerned Base document is '%3'.\n" +"\n" +"The index = %1." +msgstr "" + +#. SF_Form determination +#. %1: A form name +#. %2: A form name +#, kde-format +msgctxt "SUBFORMNOTFOUND" +msgid "" +"The requested subform could not be found below the given main form.\n" +"\n" +"The main form = '%2'.\n" +"The subform = '%1'." +msgstr "" + +#. SF_FormControl property setting +#. %1: An identifier +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#, kde-format +msgctxt "FORMCONTROLTYPE" +msgid "" +"The control '%1' in form '%2' is of type '%3'.\n" +"The property or method '%4' is not applicable on that type of form " +"controls." +msgstr "" + +#. SF_Dialog creation +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#. %5: An identifier +#. %6: A string +#. %7: An identifier +#. %8: A string +#, kde-format +msgctxt "DIALOGNOTFOUND" +msgid "" +"The requested dialog could not be located in the given container or " +"library.\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8" +msgstr "" + +#. SF_Dialog._IsStillAlive error message +#. %1: An identifier +#, kde-format +msgctxt "DIALOGDEAD" +msgid "" +"The requested action could not be executed because the dialog was " +"closed inadvertently.\n" +"\n" +"The concerned dialog is '%1'." +msgstr "" + +#. SF_DialogControl property setting +#. %1: An identifier +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#, kde-format +msgctxt "CONTROLTYPE" +msgid "" +"The control '%1' in dialog '%2' is of type '%3'.\n" +"The property or method '%4' is not applicable on that type of dialog " +"controls." +msgstr "" + +#. SF_DialogControl add line in textbox +#. %1: An identifier +#. %2: An identifier +#, kde-format +msgctxt "TEXTFIELD" +msgid "" +"The control '%1' in dialog '%2' is not a multiline text field.\n" +"The requested method could not be executed." +msgstr "" + +#. SF_Database when running update SQL statement +#. %1: The concerned method +#, kde-format +msgctxt "DBREADONLY" +msgid "" +"The database has been opened in read-only mode.\n" +"The '%1' method must not be executed in this context." +msgstr "" + +#. SF_Database can't interpret SQL statement +#. %1: The statement +#, kde-format +msgctxt "SQLSYNTAX" +msgid "" +"An SQL statement could not be interpreted or executed by the " +"database system.\n" +"Check its syntax, table and/or field names, ...\n" +"\n" +"SQL Statement : « %1 »" +msgstr "" + +#. SF_Exception.PythonShell error messageAPSO: to leave unchanged +msgctxt "PYTHONSHELL" +msgid "" +"The APSO extension could not be located in your LibreOffice " +"installation." +msgstr "" + +#. SFUnitTest could not locate the library gven as argument +#. %1: The name of the library +#, kde-format +msgctxt "UNITTESTLIBRARY" +msgid "" +"The requested library could not be located.\n" +"The UnitTest service has not been initialized.\n" +"\n" +"Library name : « %1 »" +msgstr "" + +#. SFUnitTest finds a RunTest() call in a inappropriate location +#. %1: The name of a method +#, kde-format +msgctxt "UNITTESTMETHOD" +msgid "" +"The method '%1' is unexpected in the current context.\n" +"The UnitTest service cannot proceed further with the on-going test." +msgstr "" \ No newline at end of file diff --git a/wizards/source/scriptforge/po/en.po b/wizards/source/scriptforge/po/en.po new file mode 100644 index 000000000..248d800c0 --- /dev/null +++ b/wizards/source/scriptforge/po/en.po @@ -0,0 +1,975 @@ +# +# This pristine POT file has been generated by LibreOffice/ScriptForge +# Full documentation is available on https://help.libreoffice.org/ +# +# ********************************************************************* +# *** The ScriptForge library and its associated libraries *** +# *** are part of the LibreOffice project. *** +# ********************************************************************* +# +# ScriptForge Release 7.4 +# ----------------------- +# +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: https://bugs.libreoffice.org/enter_bug.cgi?product=LibreOffice&bug_status=UNCONFIRMED&component=UI\n" +"POT-Creation-Date: 2022-05-04 18:07:20\n" +"PO-Revision-Date: YYYY-MM-DD HH:MM:SS\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"Language: en_US\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=n > 1;\n" +"X-Generator: LibreOffice - ScriptForge\n" +"X-Accelerator-Marker: ~\n" + +#. Title in error message box +#. %1: an error number +#, kde-format +msgctxt "ERRORNUMBER" +msgid "Error %1" +msgstr "" + +#. Error message box +#. %1: a line number +#, kde-format +msgctxt "ERRORLOCATION" +msgid "Location : %1" +msgstr "" + +#. Logfile record +#, kde-format +msgctxt "LONGERRORDESC" +msgid "Error %1 - Location = %2 - Description = %3" +msgstr "" + +#. Any blocking error message +msgctxt "STOPEXECUTION" +msgid "THE EXECUTION IS CANCELLED." +msgstr "" + +#. Any blocking error message +#. %1: a method name +#, kde-format +msgctxt "NEEDMOREHELP" +msgid "Do you want to receive more information about the '%1' method ?" +msgstr "" + +#. SF_Exception.RaiseAbort error message +msgctxt "INTERNALERROR" +msgid "" +"The ScriptForge library has crashed. The reason is unknown.\n" +"Maybe a bug that could be reported on\n" +" https://bugs.documentfoundation.org/\n" +"\n" +"More details : \n" +"\n" +"" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: probably ScriptForge +#. %2: service or module name +#. %3: property or method name where the error occurred +#, kde-format +msgctxt "VALIDATESOURCE" +msgid "" +"Library : %1\n" +"Service : %2\n" +"Method : %3" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: list of arguments of the method +#, kde-format +msgctxt "VALIDATEARGS" +msgid "Arguments: %1" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEERROR" +msgid "A serious error has been detected in your code on argument : « %1 »." +msgstr "" + +#. SF_Utils.Validate error message +msgctxt "VALIDATIONRULES" +msgid " Validation rules :" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: Comma separated list of allowed types +#, kde-format +msgctxt "VALIDATETYPES" +msgid " « %1 » must have next type (or one of next types) : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: Comma separated list of allowed values +#, kde-format +msgctxt "VALIDATEVALUES" +msgid " « %1 » must contain one of next values : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: A regular expression +#, kde-format +msgctxt "VALIDATEREGEX" +msgid " « %1 » must match next regular expression : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: The name of a Basic class +#, kde-format +msgctxt "VALIDATECLASS" +msgid " « %1 » must be a Basic object of class : %2" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: The value of the argument as a string +#, kde-format +msgctxt "VALIDATEACTUAL" +msgid "The actual value of « %1 » is : '%2'" +msgstr "" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEMISSING" +msgid "The « %1 » argument is mandatory, yet it is missing." +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEARRAY" +msgid " « %1 » must be an array." +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. %2: Number of dimensions of the array +#, kde-format +msgctxt "VALIDATEDIMS" +msgid " « %1 » must have exactly %2 dimension(s)." +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. %2: Either one single type or 'String, Date, Numeric' +#, kde-format +msgctxt "VALIDATEALLTYPES" +msgid " « %1 » must have all elements of the same type : %2" +msgstr "" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. NULL and EMPTY should not be translated +#, kde-format +msgctxt "VALIDATENOTNULL" +msgid " « %1 » must not contain any NULL or EMPTY elements." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. 'String' should not be translated +#, kde-format +msgctxt "VALIDATEFILE" +msgid " « %1 » must be of type String." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEFILESYS" +msgid "" +" « %1 » must be a valid file or folder name expressed in the " +"operating system native notation." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. 'URL' should not be translated +#, kde-format +msgctxt "VALIDATEFILEURL" +msgid "" +" « %1 » must be a valid file or folder name expressed in the " +"portable URL notation." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEFILEANY" +msgid " « %1 » must be a valid file or folder name." +msgstr "" + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. '(?, *)' is to be left as is +#, kde-format +msgctxt "VALIDATEWILDCARD" +msgid "" +" « %1 » may contain one or more wildcard characters (?, *) in " +"its last path component only." +msgstr "" + +#. SF_Array.RangeInit error message +#. %1, %2, %3: Numeric values +#. 'From', 'UpTo', 'ByStep' should not be translated +#, kde-format +msgctxt "ARRAYSEQUENCE" +msgid "" +"The respective values of 'From', 'UpTo' and 'ByStep' are incoherent.\n" +"\n" +" « From » = %1\n" +" « UpTo » = %2\n" +" « ByStep » = %3" +msgstr "" + +#. SF_Array.AppendColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_2D' should not be translated +#, kde-format +msgctxt "ARRAYINSERT" +msgid "" +"The array and the vector to insert have incompatible sizes.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" +msgstr "" + +#. SF_Array.ExtractColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_2D' should not be translated +#, kde-format +msgctxt "ARRAYINDEX1" +msgid "" +"The given index does not fit within the bounds of the array.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" +msgstr "" + +#. SF_Array.ExtractColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_1D', 'From' and 'UpTo' should not be translated +#, kde-format +msgctxt "ARRAYINDEX2" +msgid "" +"The given slice limits do not fit within the bounds of the array.\n" +"\n" +" « Array_1D » = %1\n" +" « From » = %2\n" +" « UpTo » = %3" +msgstr "" + +#. SF_Array.ImportFromCSVFile error message +#. %1: a file name +#. %2: numeric +#. %3: a long string +#, kde-format +msgctxt "CSVPARSING" +msgid "" +"The given file could not be parsed as a valid CSV file.\n" +"\n" +" « File name » = %1\n" +" Line number = %2\n" +" Content = %3" +msgstr "" + +#. SF_Dictionary Add/ReplaceKey error message +#. %1: An identifier%2: a (potentially long) string +#, kde-format +msgctxt "DUPLICATEKEY" +msgid "" +"The insertion of a new key into a dictionary failed because the key " +"already exists.\n" +"Note that the comparison between keys is NOT case-sensitive.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Dictionary Remove/ReplaceKey/ReplaceItem error message +#. %1: An identifier%2: a (potentially long) string +#, kde-format +msgctxt "UNKNOWNKEY" +msgid "" +"The requested key does not exist in the dictionary.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Dictionary Add/ReplaceKey error message +#. +msgctxt "INVALIDKEY" +msgid "" +"The insertion or the update of an entry into a dictionary failed " +"because the given key contains only spaces." +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "UNKNOWNFILE" +msgid "" +"The given file could not be found on your system.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A folder name +#, kde-format +msgctxt "UNKNOWNFOLDER" +msgid "" +"The given folder could not be found on your system.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "NOTAFILE" +msgid "" +"« %1 » contains the name of an existing folder, not that of a file.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A folder name +#, kde-format +msgctxt "NOTAFOLDER" +msgid "" +"« %1 » contains the name of an existing file, not that of a folder.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/... error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "OVERWRITE" +msgid "" +"You tried to create a new file which already exists. Overwriting it " +"has been rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "READONLY" +msgid "" +"Copying or moving a file to a destination which has its read-only " +"attribute set, or deleting such a file or folder is forbidden.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file or folder name with wildcards +#, kde-format +msgctxt "NOFILEMATCH" +msgid "" +"When « %1 » contains wildcards. at least one file or folder must " +"match the given filter. Otherwise the operation is rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_FileSystem CreateFolder error message +#. %1: An identifier +#. %2: A file or folder name +#, kde-format +msgctxt "FOLDERCREATION" +msgid "" +"« %1 » contains the name of an existing file or an existing folder. " +"The operation is rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Services.CreateScriptService error message +#. %1: An identifier +#. %2: A string +#. %3: A Basic library name +#. %4: A service (1 word) name +#, kde-format +msgctxt "UNKNOWNSERVICE" +msgid "" +"No service named '%4' has been registered for the library '%3'.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Services.CreateScriptService error message +#. %1: An identifier +#. %2: A string +#. %3: A Basic library name +#, kde-format +msgctxt "SERVICESNOTLOADED" +msgid "" +"The library '%3' and its services could not been loaded.\n" +"The reason is unknown.\n" +"However, checking the '%3.SF_Services.RegisterScriptServices()' " +"function and its return value can be a good starting point.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Session.ExecuteCalcFunction error message +#. 'Calc' should not be translated +#, kde-format +msgctxt "CALCFUNC" +msgid "" +"The Calc '%1' function encountered an error. Either the given " +"function does not exist or its arguments are invalid." +msgstr "" + +#. SF_Session._GetScript error message +#. %1: 'Basic' or 'Python' +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#. %5: A string +#, kde-format +msgctxt "NOSCRIPT" +msgid "" +"The requested %1 script could not be located in the given libraries " +"and modules.\n" +"« %2 » = %3\n" +"« %4 » = %5" +msgstr "" + +#. SF_Session.ExecuteBasicScript error message +#. %1: An identifier +#. %2: A string +#. %3: A (long) string +#, kde-format +msgctxt "SCRIPTEXEC" +msgid "" +"An exception occurred during the execution of the Basic script.\n" +"Cause: %3\n" +"« %1 » = %2" +msgstr "" + +#. SF_Session.SendMail error message +#. %1 = a mail address +#, kde-format +msgctxt "WRONGEMAIL" +msgid "" +"One of the email addresses has been found invalid.\n" +"Invalid mail = « %1 »" +msgstr "" + +#. SF_Session.SendMail error message +msgctxt "SENDMAIL" +msgid "" +"The message could not be sent due to a system error.\n" +"A possible cause is that LibreOffice could not find any mail client." +msgstr "" + +#. SF_TextStream._IsFileOpen error message +#. %1: A file name +#, kde-format +msgctxt "FILENOTOPEN" +msgid "" +"The requested file operation could not be executed because the file " +"was closed previously.\n" +"\n" +"File name = '%1'" +msgstr "" + +#. SF_TextStream._IsFileOpen error message +#. %1: A file name +#. %2: READ, WRITE or APPEND +#, kde-format +msgctxt "FILEOPENMODE" +msgid "" +"The requested file operation could not be executed because it is " +"incompatible with the mode in which the file was opened.\n" +"\n" +"File name = '%1'\n" +"Open mode = %2" +msgstr "" + +#. SF_TextStream.ReadLine/ReadAll/SkipLine error message +#. %1: A file name +#, kde-format +msgctxt "ENDOFFILE" +msgid "" +"The requested file read operation could not be completed because an " +"unexpected end-of-file was encountered.\n" +"\n" +"File name = '%1'" +msgstr "" + +#. SF_UI.GetDocument error message +#. %1: An identifier +#. %2: A string +#, kde-format +msgctxt "DOCUMENT" +msgid "" +"The requested document could not be found.\n" +"\n" +"%1 = '%2'" +msgstr "" + +#. SF_UI.GetDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#, kde-format +msgctxt "DOCUMENTCREATION" +msgid "" +"The creation of a new document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the document type is unknown, or no template file was given,\n" +"or the given template file was not found on your system.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" +msgstr "" + +#. SF_UI.OpenDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#. %5: An identifier +#. %6: A string +#, kde-format +msgctxt "DOCUMENTOPEN" +msgid "" +"The opening of the document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the file does not exist, or the password is wrong, or the " +"given filter is invalid.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'\n" +"%5 = '%6'" +msgstr "" + +#. SF_UI.OpenDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#, kde-format +msgctxt "BASEDOCUMENTOPEN" +msgid "" +"The opening of the Base document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the file does not exist, or the file is not registered under " +"the given name.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" +msgstr "" + +#. SF_Document._IsStillAlive error message +#. %1: A file name +#, kde-format +msgctxt "DOCUMENTDEAD" +msgid "" +"The requested action could not be executed because the document was " +"closed inadvertently.\n" +"\n" +"The concerned document is '%1'" +msgstr "" + +#. SF_Document.SaveAs error message +#. %1: An identifier +#. %2: A file name +#. +#, kde-format +msgctxt "DOCUMENTSAVE" +msgid "" +"The document could not be saved.\n" +"Either the document has been opened read-only, or the destination " +"file has a read-only attribute set, or the file where to save to is " +"undefined.\n" +"\n" +"%1 = '%2'" +msgstr "" + +#. SF_Document.SaveAs error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. %5: An identifier +#. %6: A string +#, kde-format +msgctxt "DOCUMENTSAVEAS" +msgid "" +"The document could not be saved.\n" +"Either the document must not be overwritten, or the destination file " +"has a read-only attribute set, or the given filter is invalid.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4\n" +"%5 = '%6'" +msgstr "" + +#. SF_Document any update +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "DOCUMENTREADONLY" +msgid "" +"You tried to edit a document which is not modifiable. The document " +"has not been changed.\n" +"\n" +"« %1 » = %2" +msgstr "" + +#. SF_Base GetDatabase +#. %1: An identifier +#. %2: A user name +#. %3: An identifier +#. %4: A password +#. %5: A file name +#, kde-format +msgctxt "DBCONNECT" +msgid "" +"The database related to the actual Base document could not be " +"retrieved.\n" +"Check the connection/login parameters.\n" +"\n" +"« %1 » = '%2'\n" +"« %3 » = '%4'\n" +"« Document » = %5" +msgstr "" + +#. SF_Calc _ParseAddress (sheet) +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "CALCADDRESS1" +msgid "" +"The given address does not correspond with a valid sheet name.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" + +#. SF_Calc _ParseAddress (range) +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "CALCADDRESS2" +msgid "" +"The given address does not correspond with a valid range of cells.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" + +#. SF_Calc InsertSheet +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "DUPLICATESHEET" +msgid "" +"There exists already in the document a sheet with the same name.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" + +#. SF_Calc Offset +#. %1: An identifier +#. %2: A Calc reference +#. %3: An identifier +#. %4: A number +#. %5: An identifier +#. %6: A number +#. %7: An identifier +#. %8: A number +#. %9: An identifier +#. %10: A number +#. %11: An identifier +#. %12: A file name +#, kde-format +msgctxt "OFFSETADDRESS" +msgid "" +"The computed range falls beyond the sheet boundaries or is " +"meaningless.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8\n" +"« %9 » = %10\n" +"« %11 » = %12" +msgstr "" + +#. SF_Calc CreateChart +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#. %5: An identifier +#. %6: A file name +#, kde-format +msgctxt "DUPLICATECHART" +msgid "" +"A chart with the same name exists already in the sheet.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"" +msgstr "" + +#. SF_Calc.ExportRangeToFile error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. +#, kde-format +msgctxt "RANGEEXPORT" +msgid "" +"The given range could not be exported.\n" +"Either the destination file must not be overwritten, or it has a " +"read-only attribute set.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4" +msgstr "" + +#. SF_Chart.ExportToFile error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. +#, kde-format +msgctxt "CHARTEXPORT" +msgid "" +"The chart could not be exported.\n" +"Either the destination file must not be overwritten, or it has a " +"read-only attribute set.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4" +msgstr "" + +#. SF_Dialog._IsStillAlive error message +#. %1: An identifier%2: A file name +#, kde-format +msgctxt "FORMDEAD" +msgid "" +"The requested action could not be executed because the form is not " +"open or the document was closed inadvertently.\n" +"\n" +"The concerned form is '%1' in document '%2'." +msgstr "" + +#. SF_Form determination +#. %1: A number +#. %2: A sheet name +#. %3: A file name +#, kde-format +msgctxt "CALCFORMNOTFOUND" +msgid "" +"The requested form could not be found in the Calc sheet. The given " +"index is off-limits.\n" +"\n" +"The concerned Calc document is '%3'.\n" +"\n" +"The name of the sheet = '%2'\n" +"The index = %1." +msgstr "" + +#. SF_Form determination +#. %1: A number +#. %2: A file name +#, kde-format +msgctxt "WRITERFORMNOTFOUND" +msgid "" +"The requested form could not be found in the Writer document. The " +"given index is off-limits.\n" +"\n" +"The concerned Writer document is '%2'.\n" +"\n" +"The index = %1." +msgstr "" + +#. SF_Form determination +#. %1: A number +#. %2: A string +#. %3: A file name +#, kde-format +msgctxt "BASEFORMNOTFOUND" +msgid "" +"The requested form could not be found in the form document '%2'. The " +"given index is off-limits.\n" +"\n" +"The concerned Base document is '%3'.\n" +"\n" +"The index = %1." +msgstr "" + +#. SF_Form determination +#. %1: A form name +#. %2: A form name +#, kde-format +msgctxt "SUBFORMNOTFOUND" +msgid "" +"The requested subform could not be found below the given main form.\n" +"\n" +"The main form = '%2'.\n" +"The subform = '%1'." +msgstr "" + +#. SF_FormControl property setting +#. %1: An identifier +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#, kde-format +msgctxt "FORMCONTROLTYPE" +msgid "" +"The control '%1' in form '%2' is of type '%3'.\n" +"The property or method '%4' is not applicable on that type of form " +"controls." +msgstr "" + +#. SF_Dialog creation +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#. %5: An identifier +#. %6: A string +#. %7: An identifier +#. %8: A string +#, kde-format +msgctxt "DIALOGNOTFOUND" +msgid "" +"The requested dialog could not be located in the given container or " +"library.\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8" +msgstr "" + +#. SF_Dialog._IsStillAlive error message +#. %1: An identifier +#, kde-format +msgctxt "DIALOGDEAD" +msgid "" +"The requested action could not be executed because the dialog was " +"closed inadvertently.\n" +"\n" +"The concerned dialog is '%1'." +msgstr "" + +#. SF_DialogControl property setting +#. %1: An identifier +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#, kde-format +msgctxt "CONTROLTYPE" +msgid "" +"The control '%1' in dialog '%2' is of type '%3'.\n" +"The property or method '%4' is not applicable on that type of dialog " +"controls." +msgstr "" + +#. SF_DialogControl add line in textbox +#. %1: An identifier +#. %2: An identifier +#, kde-format +msgctxt "TEXTFIELD" +msgid "" +"The control '%1' in dialog '%2' is not a multiline text field.\n" +"The requested method could not be executed." +msgstr "" + +#. SF_Database when running update SQL statement +#. %1: The concerned method +#, kde-format +msgctxt "DBREADONLY" +msgid "" +"The database has been opened in read-only mode.\n" +"The '%1' method must not be executed in this context." +msgstr "" + +#. SF_Database can't interpret SQL statement +#. %1: The statement +#, kde-format +msgctxt "SQLSYNTAX" +msgid "" +"An SQL statement could not be interpreted or executed by the " +"database system.\n" +"Check its syntax, table and/or field names, ...\n" +"\n" +"SQL Statement : « %1 »" +msgstr "" + +#. SF_Exception.PythonShell error messageAPSO: to leave unchanged +msgctxt "PYTHONSHELL" +msgid "" +"The APSO extension could not be located in your LibreOffice " +"installation." +msgstr "" + +#. SFUnitTest could not locate the library gven as argument +#. %1: The name of the library +#, kde-format +msgctxt "UNITTESTLIBRARY" +msgid "" +"The requested library could not be located.\n" +"The UnitTest service has not been initialized.\n" +"\n" +"Library name : « %1 »" +msgstr "" + +#. SFUnitTest finds a RunTest() call in a inappropriate location +#. %1: The name of a method +#, kde-format +msgctxt "UNITTESTMETHOD" +msgid "" +"The method '%1' is unexpected in the current context.\n" +"The UnitTest service cannot proceed further with the on-going test." +msgstr "" \ No newline at end of file diff --git a/wizards/source/scriptforge/po/pt.po b/wizards/source/scriptforge/po/pt.po new file mode 100644 index 000000000..a40aafd4c --- /dev/null +++ b/wizards/source/scriptforge/po/pt.po @@ -0,0 +1,1141 @@ +# +# This pristine POT file has been generated by LibreOffice/ScriptForge +# Full documentation is available on https://help.libreoffice.org/ +# +# ********************************************************************* +# *** The ScriptForge library and its associated libraries *** +# *** are part of the LibreOffice project. *** +# ********************************************************************* +# +# ScriptForge Release 7.3 +# ----------------------- +# +msgid "" +msgstr "" +"Project-Id-Version: \n" +"Report-Msgid-Bugs-To: https://bugs.libreoffice.org/enter_bug.cgi?" +"product=LibreOffice&bug_status=UNCONFIRMED&component=UI\n" +"POT-Creation-Date: 2021-06-19 16:57:15\n" +"PO-Revision-Date: 2021-06-28 18:30-0300\n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n > 1);\n" +"X-Generator: Poedit 3.0\n" +"X-Accelerator-Marker: ~\n" +"Last-Translator: \n" +"Language: pt_BR\n" + +#. Text in close buttons of progress and console dialog boxes +msgctxt "CLOSEBUTTON" +msgid "Close" +msgstr "Fechar" + +#. Title in error message box +#. %1: an error number +#, kde-format +msgctxt "ERRORNUMBER" +msgid "Error %1" +msgstr "Erro %1" + +#. Error message box +#. %1: a line number +#, kde-format +msgctxt "ERRORLOCATION" +msgid "Location : %1" +msgstr "Localização : %1" + +#. Logfile record +#, kde-format +msgctxt "LONGERRORDESC" +msgid "Error %1 - Location = %2 - Description = %3" +msgstr "Erro %1 - Localização = %2 - Descrição = %3" + +#. SF_Utils._Validate error message +msgctxt "STOPEXECUTION" +msgid "THE EXECUTION IS CANCELLED." +msgstr "A EXECUÇÃO FOI CANCELADA." + +#. SF_Exception.RaiseAbort error message +msgctxt "INTERNALERROR" +msgid "" +"The ScriptForge library has crashed. The reason is unknown.\n" +"Maybe a bug that could be reported on\n" +" https://bugs.documentfoundation.org/\n" +"\n" +"More details : \n" +"\n" +msgstr "" +"A biblioteca ScriptForge encontrou um erro grave. A razão é desconhecida.\n" +"Talvez seja um bug que pode ser relatado em\n" +" https://bugs.documentfoundation.org/\n" +"\n" +"Mais detalhes: \n" +"\n" + +#. SF_Utils._Validate error message +#. %1: probably ScriptForge +#. %2: service or module name +#. %3: property or method name where the error occurred +#, kde-format +msgctxt "VALIDATESOURCE" +msgid "" +"Library : %1\n" +"Service : %2\n" +"Method : %3" +msgstr "" +"Biblioteca : %1\n" +"Serviço : %2\n" +"Método : %3" + +#. SF_Utils._Validate error message +#. %1: list of arguments of the method +#, kde-format +msgctxt "VALIDATEARGS" +msgid "Arguments: %1" +msgstr "Argumentos: %1" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEERROR" +msgid "A serious error has been detected in your code on argument : « %1 »." +msgstr "Um erro grave foi detectado em seu código no argumento : « %1»." + +#. SF_Utils.Validate error message +msgctxt "VALIDATIONRULES" +msgid " Validation rules :" +msgstr " Regras de validação:" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: Comma separated list of allowed types +#, kde-format +msgctxt "VALIDATETYPES" +msgid " « %1 » must have next type (or one of next types) : %2" +msgstr "" +" « %1 » deve ter o seguinte tipo (ou um dos tipos a seguir) : %2" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: Comma separated list of allowed values +#, kde-format +msgctxt "VALIDATEVALUES" +msgid " « %1 » must contain one of next values : %2" +msgstr " « %1 » deve conter um dos seguintes valores : %2" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: A regular expression +#, kde-format +msgctxt "VALIDATEREGEX" +msgid " « %1 » must match next regular expression : %2" +msgstr " « %1 » deve corresponder à seguinte expressão regular : %2" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: The name of a Basic class +#, kde-format +msgctxt "VALIDATECLASS" +msgid " « %1 » must be a Basic object of class : %2" +msgstr " « %1 » deve ser um objeto ou classe Basic : %2" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#. %2: The value of the argument as a string +#, kde-format +msgctxt "VALIDATEACTUAL" +msgid "The actual value of « %1 » is : '%2'" +msgstr "O valor atual de « %1 » é : '%2'" + +#. SF_Utils._Validate error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEMISSING" +msgid "The « %1 » argument is mandatory, yet it is missing." +msgstr "O argumento « %1 » é obrigatório, porém está ausente." + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEARRAY" +msgid " « %1 » must be an array." +msgstr " « %1 » deve ser um array." + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. %2: Number of dimensions of the array +#, kde-format +msgctxt "VALIDATEDIMS" +msgid " « %1 » must have exactly %2 dimension(s)." +msgstr " « %1 » deve ter exatamente %2 dimensão(ões)." + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. %2: Either one single type or 'String, Date, Numeric' +#, kde-format +msgctxt "VALIDATEALLTYPES" +msgid " « %1 » must have all elements of the same type : %2" +msgstr " « %1 » deve ter todos os elementos de um mesmo tipo : %2" + +#. SF_Utils._ValidateArray error message +#. %1: Wrong argument name +#. NULL and EMPTY should not be translated +#, kde-format +msgctxt "VALIDATENOTNULL" +msgid " « %1 » must not contain any NULL or EMPTY elements." +msgstr " « %1 » não pode conter nenhum elemento NULL ou EMPTY." + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. 'String' should not be translated +#, kde-format +msgctxt "VALIDATEFILE" +msgid " « %1 » must be of type String." +msgstr " « %1 » deve ser to tipo String." + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEFILESYS" +msgid "" +" « %1 » must be a valid file or folder name expressed in the " +"operating system native notation." +msgstr "" +" « %1 » deve ser um nome válido de arquivo ou pasta expresso usando a " +"notação do sistema operacional." + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. 'URL' should not be translated +#, kde-format +msgctxt "VALIDATEFILEURL" +msgid "" +" « %1 » must be a valid file or folder name expressed in the portable " +"URL notation." +msgstr "" +" « %1 » deve ser um nome válido de arquivo ou pasta expresso usando a " +"notação portável URL." + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#, kde-format +msgctxt "VALIDATEFILEANY" +msgid " « %1 » must be a valid file or folder name." +msgstr " « %1 » deve ser um nome válido de arquivo ou pasta." + +#. SF_Utils._ValidateFile error message +#. %1: Wrong argument name +#. '(?, *)' is to be left as is +#, kde-format +msgctxt "VALIDATEWILDCARD" +msgid "" +" « %1 » may contain one or more wildcard characters (?, *) in its " +"last path component only." +msgstr "" +" « %1 » deve conter um ou mais caracteres coringa (?,*) apenas no " +"último componente do caminho." + +#. SF_Array.RangeInit error message +#. %1, %2, %3: Numeric values +#. 'From', 'UpTo', 'ByStep' should not be translated +#, kde-format +msgctxt "ARRAYSEQUENCE" +msgid "" +"The respective values of 'From', 'UpTo' and 'ByStep' are incoherent.\n" +"\n" +" « From » = %1\n" +" « UpTo » = %2\n" +" « ByStep » = %3" +msgstr "" +"Os valores informados para 'From', 'UpTo' e 'ByStep' são incoerentes.\n" +"\n" +" « From » = %1\n" +" « UpTo » = %2\n" +" « ByStep » = %3" + +#. SF_Array.AppendColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_2D' should not be translated +#, kde-format +msgctxt "ARRAYINSERT" +msgid "" +"The array and the vector to insert have incompatible sizes.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" +msgstr "" +"O array e vetor a serem inseridos têm tamanhos incompatíveis.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" + +#. SF_Array.ExtractColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_2D' should not be translated +#, kde-format +msgctxt "ARRAYINDEX1" +msgid "" +"The given index does not fit within the bounds of the array.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" +msgstr "" +"O índice fornecido não cabe nos limites do array.\n" +"\n" +" « Array_2D » = %2\n" +" « %1 » = %3" + +#. SF_Array.ExtractColumn (...) error message +#. %1: 'Column' or 'Row' of a matrix +#. %2, %3: array contents +#. 'Array_1D', 'From' and 'UpTo' should not be translated +#, kde-format +msgctxt "ARRAYINDEX2" +msgid "" +"The given slice limits do not fit within the bounds of the array.\n" +"\n" +" « Array_1D » = %1\n" +" « From » = %2\n" +" « UpTo » = %3" +msgstr "" +"Os limites fornecidos para o intervalo não cabem nos limites do array.\n" +"\n" +" « Array_1D » = %1\n" +" « From » = %2\n" +" « UpTo » = %3" + +#. SF_Array.ImportFromCSVFile error message +#. %1: a file name +#. %2: numeric +#. %3: a long string +#, kde-format +msgctxt "CSVPARSING" +msgid "" +"The given file could not be parsed as a valid CSV file.\n" +"\n" +" « File name » = %1\n" +" Line number = %2\n" +" Content = %3" +msgstr "" +"O arquivo fornecido não pode ser processada como um arquivo CSV válido.\n" +"\n" +" « Arquivo » = %1\n" +" Número da linha = %2\n" +" Conteúdo = %3" + +#. SF_Dictionary Add/ReplaceKey error message +#. %1: An identifier%2: a (potentially long) string +#, kde-format +msgctxt "DUPLICATEKEY" +msgid "" +"The insertion of a new key into a dictionary failed because the key already " +"exists.\n" +"Note that the comparison between keys is NOT case-sensitive.\n" +"\n" +"« %1 » = %2" +msgstr "" +"A inserção de uma nova chave ao dicionário falhou porque a chave já existe.\n" +"Note que comparações entre chaves não são sensíveis à caixa.\n" +"\n" +"« %1 » = %2" + +#. SF_Dictionary Remove/ReplaceKey/ReplaceItem error message +#. %1: An identifier%2: a (potentially long) string +#, kde-format +msgctxt "UNKNOWNKEY" +msgid "" +"The requested key does not exist in the dictionary.\n" +"\n" +"« %1 » = %2" +msgstr "" +"A chave requerida não existe no dicionário.\n" +"\n" +"« %1 » = %2" + +#. SF_Dictionary Add/ReplaceKey error message +#. +msgctxt "INVALIDKEY" +msgid "" +"The insertion or the update of an entry into a dictionary failed because the " +"given key contains only spaces." +msgstr "" +"A inserção ou atualização de uma entrada em um dicionário falhou porque a " +"chave fornecido contém apenas espaços." + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "UNKNOWNFILE" +msgid "" +"The given file could not be found on your system.\n" +"\n" +"« %1 » = %2" +msgstr "" +"O arquivo fornecido não foi encontrado em seu sistema.\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A folder name +#, kde-format +msgctxt "UNKNOWNFOLDER" +msgid "" +"The given folder could not be found on your system.\n" +"\n" +"« %1 » = %2" +msgstr "" +"O diretório fornecido não foi encontrado em seu sistema.\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "NOTAFILE" +msgid "" +"« %1 » contains the name of an existing folder, not that of a file.\n" +"\n" +"« %1 » = %2" +msgstr "" +"« %1 » contém o nome de um diretório existente em vez de conter o nome de um " +"arquivo.\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A folder name +#, kde-format +msgctxt "NOTAFOLDER" +msgid "" +"« %1 » contains the name of an existing file, not that of a folder.\n" +"\n" +"« %1 » = %2" +msgstr "" +"« %1 » contém o nome de um arquivo existente em vez de conter o nome de um " +"diretório.\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem copy/move/... error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "OVERWRITE" +msgid "" +"You tried to create a new file which already exists. Overwriting it has been " +"rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" +"Você tentou criar um novo arquivo que já existe. Sobrescrever o arquivo não " +"foi permitido\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "READONLY" +msgid "" +"Copying or moving a file to a destination which has its read-only attribute " +"set, or deleting such a file or folder is forbidden.\n" +"\n" +"« %1 » = %2" +msgstr "" +"Copiar ou mover um arquivo para um destino que tem o atributo somente-" +"leitura definido, bem como apagar tais arquivos ou pastas, não é permitido.\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem copy/move/delete error message +#. %1: An identifier +#. %2: A file or folder name with wildcards +#, kde-format +msgctxt "NOFILEMATCH" +msgid "" +"When « %1 » contains wildcards. at least one file or folder must match the " +"given filter. Otherwise the operation is rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" +"Quando « %1 » contiver caracteres coringa, ao menos um arquivo ou pasta deve " +"corresponder ao filtro especificado. Caso contrário, a operação será " +"rejeitada.\n" +"\n" +"« %1 » = %2" + +#. SF_FileSystem CreateFolder error message +#. %1: An identifier +#. %2: A file or folder name +#, kde-format +msgctxt "FOLDERCREATION" +msgid "" +"« %1 » contains the name of an existing file or an existing folder. The " +"operation is rejected.\n" +"\n" +"« %1 » = %2" +msgstr "" +"« %1 » contém o nome de um arquivo ou pasta existente. A operação foi " +"rejeitada.\n" +"\n" +"« %1 » = %2" + +#. SF_Services.CreateScriptService error message +#. %1: An identifier +#. %2: A string +#. %3: A Basic library name +#. %4: A service (1 word) name +#, kde-format +msgctxt "UNKNOWNSERVICE" +msgid "" +"No service named '%4' has been registered for the library '%3'.\n" +"\n" +"« %1 » = %2" +msgstr "" +"Nenhum serviço com o nome '%4' foi registrado na biblioteca '%3'.\n" +"\n" +"« %1 » = %2" + +#. SF_Services.CreateScriptService error message +#. %1: An identifier +#. %2: A string +#. %3: A Basic library name +#, kde-format +msgctxt "SERVICESNOTLOADED" +msgid "" +"The library '%3' and its services could not been loaded.\n" +"The reason is unknown.\n" +"However, checking the '%3.SF_Services.RegisterScriptServices()' function and " +"its return value can be a good starting point.\n" +"\n" +"« %1 » = %2" +msgstr "" +"A biblioteca '%3' e seus serviços não puderam ser carregados.\n" +"A razão é desconhecida.\n" +"Contudo, verificar a função '%3.SF_Services.RegisterScriptServices()' e seu " +"valor de retorno pode ser um bom ponto de partida.\n" +"\n" +"« %1 » = %2" + +#. SF_Session.ExecuteCalcFunction error message +#. 'Calc' should not be translated +#, kde-format +msgctxt "CALCFUNC" +msgid "" +"The Calc '%1' function encountered an error. Either the given function does " +"not exist or its arguments are invalid." +msgstr "" +"A função Calc '%1' encontrou um erro. Ou a função dada não existe ou seus " +"argumentos são inválidos." + +#. SF_Session._GetScript error message +#. %1: 'Basic' or 'Python' +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#. %5: A string +#, kde-format +msgctxt "NOSCRIPT" +msgid "" +"The requested %1 script could not be located in the given libraries and " +"modules.\n" +"« %2 » = %3\n" +"« %4 » = %5" +msgstr "" +"O script %1 não pode ser localizado nas bibliotecas e módulos " +"especificados.\n" +"« %2 » = %3\n" +"« %4 » = %5" + +#. SF_Session.ExecuteBasicScript error message +#. %1: An identifier +#. %2: A string +#. %3: A (long) string +#, kde-format +msgctxt "SCRIPTEXEC" +msgid "" +"An exception occurred during the execution of the Basic script.\n" +"Cause: %3\n" +"« %1 » = %2" +msgstr "" +"Uma exceção ocorreu durante a execução do script Basic.\n" +"Cause: %3\n" +"« %1 » = %2" + +#. SF_Session.SendMail error message +#. %1 = a mail address +#, kde-format +msgctxt "WRONGEMAIL" +msgid "" +"One of the email addresses has been found invalid.\n" +"Invalid mail = « %1 »" +msgstr "" +"Um dos endereços de e-mail foram considerados inválidos.\n" +"E-mail inválido = « %1 »" + +#. SF_Session.SendMail error message +msgctxt "SENDMAIL" +msgid "" +"The message could not be sent due to a system error.\n" +"A possible cause is that LibreOffice could not find any mail client." +msgstr "" +"Esta mensagem não pode ser enviada devido a um erro de sistema.\n" +"Uma possível causa é que o LibreOffice não pode encontrar um cliente de e-" +"mail." + +#. SF_TextStream._IsFileOpen error message +#. %1: A file name +#, kde-format +msgctxt "FILENOTOPEN" +msgid "" +"The requested file operation could not be executed because the file was " +"closed previously.\n" +"\n" +"File name = '%1'" +msgstr "" +"A operação de arquivo não pode ser executada porque o arquivo foi fechado " +"previamente.\n" +"\n" +"Nome do arquivo = '%1'" + +#. SF_TextStream._IsFileOpen error message +#. %1: A file name +#. %2: READ, WRITE or APPEND +#, kde-format +msgctxt "FILEOPENMODE" +msgid "" +"The requested file operation could not be executed because it is " +"incompatible with the mode in which the file was opened.\n" +"\n" +"File name = '%1'\n" +"Open mode = %2" +msgstr "" +"A operação de arquivo não pode ser executada porque é incompatível com o " +"modo de abertura do arquivo.\n" +"\n" +"Nome do arquivo = '%1'\n" +"Modo de abertura = %2" + +#. SF_TextStream.ReadLine/ReadAll/SkipLine error message +#. %1: A file name +#, kde-format +msgctxt "ENDOFFILE" +msgid "" +"The requested file read operation could not be completed because an " +"unexpected end-of-file was encountered.\n" +"\n" +"File name = '%1'" +msgstr "" +"A operação de leitura de arquivo não pode ser completada porque um fim-de-" +"arquivo inesperado foi encontrado.\n" +"\n" +"Nome do arquivo = '%1'" + +#. SF_UI.GetDocument error message +#. %1: An identifier +#. %2: A string +#, kde-format +msgctxt "DOCUMENT" +msgid "" +"The requested document could not be found.\n" +"\n" +"%1 = '%2'" +msgstr "" +"O documento desejado não pode ser encontrado.\n" +"\n" +"%1 = '%2'" + +#. SF_UI.GetDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#, kde-format +msgctxt "DOCUMENTCREATION" +msgid "" +"The creation of a new document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the document type is unknown, or no template file was given,\n" +"or the given template file was not found on your system.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" +msgstr "" +"A criação de um novo documento falhou.\n" +"Deve haver algo de errado com algum dos argumentos.\n" +"\n" +"Ou o tipo do documento é desconhecido, ou nenhum arquivo de template foi " +"especificado,\n" +"ou o arquivo do template especificado não foi encontrado no sistema.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" + +#. SF_UI.OpenDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#. %5: An identifier +#. %6: A string +#, kde-format +msgctxt "DOCUMENTOPEN" +msgid "" +"The opening of the document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the file does not exist, or the password is wrong, or the given " +"filter is invalid.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'\n" +"%5 = '%6'" +msgstr "" +"A abertura do documento falhou.\n" +"Deve haver algo de errado com um ou mais argumentos.\n" +"\n" +"Ou o arquivo não existe, ou a senha está incorreta, ou o filtro especificado " +"é inválido.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'\n" +"%5 = '%6'" + +#. SF_UI.OpenDocument error message +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A string +#, kde-format +msgctxt "BASEDOCUMENTOPEN" +msgid "" +"The opening of the Base document failed.\n" +"Something must be wrong with some arguments.\n" +"\n" +"Either the file does not exist, or the file is not registered under the " +"given name.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" +msgstr "" +"A abertura do documento Base falhou.\n" +"Deve haver algo de errado em algum dos argumentos.\n" +"\n" +"Ou o arquivo não existe, ou o arquivo não está registrado com o nome " +"informado.\n" +"\n" +"%1 = '%2'\n" +"%3 = '%4'" + +#. SF_Document._IsStillAlive error message +#. %1: A file name +#, kde-format +msgctxt "DOCUMENTDEAD" +msgid "" +"The requested action could not be executed because the document was closed " +"inadvertently.\n" +"\n" +"The concerned document is '%1'" +msgstr "" +"A ação desejada não pode ser executada porque o documento foi fechado " +"inesperadamente.\n" +"\n" +"O documento que gerou o erro foi '%1'" + +#. SF_Document.SaveAs error message +#. %1: An identifier +#. %2: A file name +#. +#, kde-format +msgctxt "DOCUMENTSAVE" +msgid "" +"The document could not be saved.\n" +"Either the document has been opened read-only, or the destination file has a " +"read-only attribute set, or the file where to save to is undefined.\n" +"\n" +"%1 = '%2'" +msgstr "" +"O documento não pode ser salvo.\n" +"Ou o documento foi aberto como somente-leitura, ou o arquivo de destino é " +"somente leitura, ou o arquivo onde o documento será salvo é indefinido.\n" +"\n" +"%1 = '%2'" + +#. SF_Document.SaveAs error message +#. %1: An identifier +#. %2: A file name +#. %3: An identifier +#. %4: True or False +#. %5: An identifier +#. %6: A string +#, kde-format +msgctxt "DOCUMENTSAVEAS" +msgid "" +"The document could not be saved.\n" +"Either the document must not be overwritten, or the destination file has a " +"read-only attribute set, or the given filter is invalid.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4\n" +"%5 = '%6'" +msgstr "" +"O documento não pode ser salvo.\n" +"Ou o documento não pode ser sobrescrito, ou o arquivo de destino é somente " +"leitura, ou o filtro especificado é inválido.\n" +"\n" +"%1 = '%2'\n" +"%3 = %4\n" +"%5 = '%6'" + +#. SF_Document any update +#. %1: An identifier +#. %2: A file name +#, kde-format +msgctxt "DOCUMENTREADONLY" +msgid "" +"You tried to edit a document which is not modifiable. The document has not " +"been changed.\n" +"\n" +"« %1 » = %2" +msgstr "" +"Você tentou editar um documento que não é modificável. O documento não foi " +"alterado.\n" +"\n" +"« %1 » = %2" + +#. SF_Base GetDatabase +#. %1: An identifier +#. %2: A user name +#. %3: An identifier +#. %4: A password +#. %5: A file name +#, kde-format +msgctxt "DBCONNECT" +msgid "" +"The database related to the actual Base document could not be retrieved.\n" +"Check the connection/login parameters.\n" +"\n" +"« %1 » = '%2'\n" +"« %3 » = '%4'\n" +"« Document » = %5" +msgstr "" +"O banco de dados associado ao documento Base atual não pode ser recuperado.\n" +"Verifique os parâmetros de conexão e login.\n" +"\n" +"« %1 » = '%2'\n" +"« %3 » = '%4'\n" +"« Documento » = %5" + +#. SF_Calc _ParseAddress (sheet) +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "CALCADDRESS1" +msgid "" +"The given address does not correspond with a valid sheet name.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" +"O endereço fornecido não corresponde a um nome de planilha válido.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" + +#. SF_Calc _ParseAddress (range) +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "CALCADDRESS2" +msgid "" +"The given address does not correspond with a valid range of cells.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" +"O endereço fornecido não corresponde a um intervalo de células válido.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" + +#. SF_Calc InsertSheet +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#, kde-format +msgctxt "DUPLICATESHEET" +msgid "" +"There exists already in the document a sheet with the same name.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" +msgstr "" +"Já existe no documento uma planilha com o mesmo nome.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4" + +#. SF_Calc Offset +#. %1: An identifier +#. %2: A Calc reference +#. %3: An identifier +#. %4: A number +#. %5: An identifier +#. %6: A number +#. %7: An identifier +#. %8: A number +#. %9: An identifier +#. %10: A number +#. %11: An identifier +#. %12: A file name +#, kde-format +msgctxt "OFFSETADDRESS" +msgid "" +"The computed range falls beyond the sheet boundaries or is meaningless.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8\n" +"« %9 » = %10\n" +"« %11 » = %12" +msgstr "" +"O intervalo computado vai além dos limites da planilha ou não tem sentido.\n" +"\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8\n" +"« %9 » = %10\n" +"« %11 » = %12" + +#. SF_Dialog._IsStillAlive error message +#. %1: An identifier%2: A file name +#, kde-format +msgctxt "FORMDEAD" +msgid "" +"The requested action could not be executed because the form is not open or " +"the document was closed inadvertently.\n" +"\n" +"The concerned form is '%1' in document '%2'." +msgstr "" +"A ação desejada não pode ser executada porque o formulário não está aberto " +"ou o documento foi fechado inesperadamente.\n" +"\n" +"O formulário em questão é '%1' no documento '%2'." + +#. SF_Form determination +#. %1: A number +#. %2: A sheet name +#. %3: A file name +#, kde-format +msgctxt "CALCFORMNOTFOUND" +msgid "" +"The requested form could not be found in the Calc sheet. The given index is " +"off-limits.\n" +"\n" +"The concerned Calc document is '%3'.\n" +"\n" +"The name of the sheet = '%2'\n" +"The index = %1." +msgstr "" +"O formulário desejado não pode ser encontrada na planilha Calc. O índice " +"dado está além dos limites.\n" +"\n" +"O documento Calc em questão é '%3'.\n" +"\n" +"Nome da planilha = '%2'\n" +"Índice da planilha = %1." + +#. SF_Form determination +#. %1: A number +#. %2: A file name +#, kde-format +msgctxt "WRITERFORMNOTFOUND" +msgid "" +"The requested form could not be found in the Writer document. The given " +"index is off-limits.\n" +"\n" +"The concerned Writer document is '%2'.\n" +"\n" +"The index = %1." +msgstr "" +"O formulário desejado não pode ser encontrado no documento Writer. O índice " +"informado está além dos limites.\n" +"\n" +"O document Writer em questão é '%2'.\n" +"\n" +"Índice do formulário = %1." + +#. SF_Form determination +#. %1: A number +#. %2: A string +#. %3: A file name +#, kde-format +msgctxt "BASEFORMNOTFOUND" +msgid "" +"The requested form could not be found in the form document '%2'. The given " +"index is off-limits.\n" +"\n" +"The concerned Base document is '%3'.\n" +"\n" +"The index = %1." +msgstr "" +"O formulário desejado não pode ser encontrado no documento de formulário " +"'%2'. O índice informado está além dos limites.\n" +"\n" +"O documento Base em questão é '%3'.\n" +"\n" +"Índice do formulário = %1." + +#. SF_Form determination +#. %1: A form name +#. %2: A form name +#, kde-format +msgctxt "SUBFORMNOTFOUND" +msgid "" +"The requested subform could not be found below the given main form.\n" +"\n" +"The main form = '%2'.\n" +"The subform = '%1'." +msgstr "" +"O sub-formulário desejado não pode ser encontrado como parte do formulário " +"principal.\n" +"\n" +"Formulário principal = '%2'.\n" +"Sub-formulário = '%1'." + +#. SF_FormControl property setting +#. %1: An identifier +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#, kde-format +msgctxt "FORMCONTROLTYPE" +msgid "" +"The control '%1' in form '%2' is of type '%3'.\n" +"The property or method '%4' is not applicable on that type of form controls." +msgstr "" +"O controle '%1' no formulário '%2' é do tipo '%3'.\n" +"A propriedade ou método '%4' não é aplicável a este tipo de controle de " +"formulário." + +#. SF_Dialog creation +#. %1: An identifier +#. %2: A string +#. %3: An identifier +#. %4: A file name +#. %5: An identifier +#. %6: A string +#. %7: An identifier +#. %8: A string +#, kde-format +msgctxt "DIALOGNOTFOUND" +msgid "" +"The requested dialog could not be located in the given container or " +"library.\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8" +msgstr "" +"O diálogo desejado não pode ser localizado no container ou biblioteca " +"informado.\n" +"« %1 » = %2\n" +"« %3 » = %4\n" +"« %5 » = %6\n" +"« %7 » = %8" + +#. SF_Dialog._IsStillAlive error message +#. %1: An identifier +#, kde-format +msgctxt "DIALOGDEAD" +msgid "" +"The requested action could not be executed because the dialog was closed " +"inadvertently.\n" +"\n" +"The concerned dialog is '%1'." +msgstr "" +"A ação desejada não pode ser executada porque o diálogo foi fechado " +"inesperadamente.\n" +"\n" +"O diálogo em questão é '%1'." + +#. SF_DialogControl property setting +#. %1: An identifier +#. %2: An identifier +#. %3: A string +#. %4: An identifier +#, kde-format +msgctxt "CONTROLTYPE" +msgid "" +"The control '%1' in dialog '%2' is of type '%3'.\n" +"The property or method '%4' is not applicable on that type of dialog " +"controls." +msgstr "" +"O controle '%1' no diálogo '%2' é do tipo '%3'.\n" +"A propriedade ou método '%4' não é aplicável a este tipo de controle de " +"diálogo." + +#. SF_DialogControl add line in textbox +#. %1: An identifier +#. %2: An identifier +#, kde-format +msgctxt "TEXTFIELD" +msgid "" +"The control '%1' in dialog '%2' is not a multiline text field.\n" +"The requested method could not be executed." +msgstr "" +"O controle '%1' no diálogo '%2' não é uma caixa de edição de textos de " +"múltiplas linhas.\n" +"O método desejado não pode ser executado." + +#. SF_Database when running update SQL statement +#. %1: The concerned method +#, kde-format +msgctxt "DBREADONLY" +msgid "" +"The database has been opened in read-only mode.\n" +"The '%1' method must not be executed in this context." +msgstr "" +"O banco de dados foi aberto no modo somente-leitura.\n" +"O método '%1' não pode ser executado neste contexto." + +#. SF_Database can't interpret SQL statement +#. %1: The statement +#, kde-format +msgctxt "SQLSYNTAX" +msgid "" +"An SQL statement could not be interpreted or executed by the database " +"system.\n" +"Check its syntax, table and/or field names, ...\n" +"\n" +"SQL Statement : « %1 »" +msgstr "" +"Uma instrução SQL não pode ser interpretada ou executada pelo sistema de " +"banco de dados.\n" +"Verifique sua sintaxe, nomes de tabelas, campos, etc...\n" +"\n" +"Instrução SQL : « %1 »" + +#. SF_Exception.PythonShell error messageAPSO: to leave unchanged +msgctxt "PYTHONSHELL" +msgid "" +"The APSO extension could not be located in your LibreOffice installation." +msgstr "" +"A extensão APSO não pode ser localizada sem sua instalação do LibreOffice." diff --git a/wizards/source/scriptforge/python/ScriptForgeHelper.py b/wizards/source/scriptforge/python/ScriptForgeHelper.py new file mode 100644 index 000000000..396273233 --- /dev/null +++ b/wizards/source/scriptforge/python/ScriptForgeHelper.py @@ -0,0 +1,317 @@ +# -*- coding: utf-8 -*- + +# Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +# ====================================================================================================================== +# === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +# === Full documentation is available on https://help.libreoffice.org/ === +# ====================================================================================================================== + +# ScriptForge is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +# 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +# distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +# 2) The GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. If a copy of the LGPL was not +# distributed with this file, see http://www.gnu.org/licenses/ . + +""" +Collection of Python helper functions called from the ScriptForge Basic libraries +to execute specific services that are not or not easily available from Basic directly. +""" + +import getpass +import os +import platform +import hashlib +import filecmp +import webbrowser +import json + + +class _Singleton(type): + """ + A Singleton design pattern + Credits: « Python in a Nutshell » by Alex Martelli, O'Reilly + """ + instances = {} + + def __call__(cls, *args, **kwargs): + if cls not in cls.instances: + cls.instances[cls] = super(_Singleton, cls).__call__(*args, **kwargs) + return cls.instances[cls] + + +# ################################################################# +# Dictionary service +# ################################################################# + +def _SF_Dictionary__ConvertToJson(propval, indent = None) -> str: + # used by Dictionary.ConvertToJson() Basic method + """ + Given an array of PropertyValues as argument, convert it to a JSON string + """ + # Array of property values => Dict(ionary) => JSON + pvDict = {} + for pv in propval: + pvDict[pv.Name] = pv.Value + return json.dumps(pvDict, indent=indent, skipkeys=True) + + +def _SF_Dictionary__ImportFromJson(jsonstr: str): # used by Dictionary.ImportFromJson() Basic method + """ + Given a JSON string as argument, convert it to a list of tuples (name, value) + The value must not be a (sub)dict. This doesn't pass the python-basic bridge. + """ + # JSON => Dictionary => Array of tuples/lists + dico = json.loads(jsonstr) + result = [] + for key in iter(dico): + value = dico[key] + item = value + if isinstance(value, dict): # check that first level is not itself a (sub)dict + item = None + elif isinstance(value, list): # check every member of the list is not a (sub)dict + for i in range(len(value)): + if isinstance(value[i], dict): value[i] = None + result.append((key, item)) + return result + + +# ################################################################# +# Exception service +# ################################################################# + +def _SF_Exception__PythonPrint(string: str) -> bool: + # used by SF_Exception.PythonPrint() Basic method + """ + Write the argument to stdout. + If the APSO shell console is active, the argument will be displayed in the console window + """ + print(string) + return True + + +# ################################################################# +# FileSystem service +# ################################################################# + +def _SF_FileSystem__CompareFiles(filename1: str, filename2: str, comparecontents=True) -> bool: + # used by SF_FileSystem.CompareFiles() Basic method + """ + Compare the 2 files, returning True if they seem equal, False otherwise. + By default, only their signatures (modification time, ...) are compared. + When comparecontents == True, their contents are compared. + """ + try: + return filecmp.cmp(filename1, filename2, not comparecontents) + except Exception: + return False + + +def _SF_FileSystem__GetFilelen(systemfilepath: str) -> str: # used by SF_FileSystem.GetFilelen() Basic method + return str(os.path.getsize(systemfilepath)) + + +def _SF_FileSystem__HashFile(filename: str, algorithm: str) -> str: # used by SF_FileSystem.HashFile() Basic method + """ + Hash a given file with the given hashing algorithm + cfr. https://www.pythoncentral.io/hashing-files-with-python/ + Example + hash = _SF_FileSystem__HashFile('myfile.txt','MD5') + """ + algo = algorithm.lower() + try: + if algo in hashlib.algorithms_guaranteed: + BLOCKSIZE = 65535 # Provision for large size files + if algo == 'md5': + hasher = hashlib.md5() + elif algo == 'sha1': + hasher = hashlib.sha1() + elif algo == 'sha224': + hasher = hashlib.sha224() + elif algo == 'sha256': + hasher = hashlib.sha256() + elif algo == 'sha384': + hasher = hashlib.sha384() + elif algo == 'sha512': + hasher = hashlib.sha512() + else: + return '' + with open(filename, 'rb') as file: # open in binary mode + buffer = file.read(BLOCKSIZE) + while len(buffer) > 0: + hasher.update(buffer) + buffer = file.read(BLOCKSIZE) + return hasher.hexdigest() + else: + return '' + except Exception: + return '' + + +# ################################################################# +# Platform service +# ################################################################# + +def _SF_Platform(propertyname: str): # used by SF_Platform Basic module + """ + Switch between SF_Platform properties (read the documentation about the ScriptForge.Platform service) + """ + pf = Platform() + if propertyname == 'Architecture': + return pf.Architecture + elif propertyname == 'ComputerName': + return pf.ComputerName + elif propertyname == 'CPUCount': + return pf.CPUCount + elif propertyname == 'CurrentUser': + return pf.CurrentUser + elif propertyname == 'Machine': + return pf.Machine + elif propertyname == 'OSName': + return pf.OSName + elif propertyname == 'OSPlatform': + return pf.OSPlatform + elif propertyname == 'OSRelease': + return pf.OSRelease + elif propertyname == 'OSVersion': + return pf.OSVersion + elif propertyname == 'Processor': + return pf.Processor + elif propertyname == 'PythonVersion': + return pf.PythonVersion + else: + return None + + +class Platform(object, metaclass = _Singleton): + @property + def Architecture(self): return platform.architecture()[0] + + @property # computer's network name + def ComputerName(self): return platform.node() + + @property # number of CPU's + def CPUCount(self): return os.cpu_count() + + @property + def CurrentUser(self): + try: + return getpass.getuser() + except Exception: + return '' + + @property # machine type e.g. 'i386' + def Machine(self): return platform.machine() + + @property # system/OS name e.g. 'Darwin', 'Java', 'Linux', ... + def OSName(self): return platform.system().replace('Darwin', 'macOS') + + @property # underlying platform e.g. 'Windows-10-...' + def OSPlatform(self): return platform.platform(aliased = True) + + @property # system's release e.g. '2.2.0' + def OSRelease(self): return platform.release() + + @property # system's version + def OSVersion(self): return platform.version() + + @property # real processor name e.g. 'amdk' + def Processor(self): return platform.processor() + + @property # Python major.minor.patchlevel + def PythonVersion(self): return 'Python ' + platform.python_version() + + +# ################################################################# +# Session service +# ################################################################# + +def _SF_Session__OpenURLInBrowser(url: str): # Used by SF_Session.OpenURLInBrowser() Basic method + """ + Display url using the default browser + """ + try: + webbrowser.open(url, new = 2) + finally: + return None + + +# ################################################################# +# String service +# ################################################################# + +def _SF_String__HashStr(string: str, algorithm: str) -> str: # used by SF_String.HashStr() Basic method + """ + Hash a given UTF-8 string with the given hashing algorithm + Example + hash = _SF_String__HashStr('This is a UTF-8 encoded string.','MD5') + """ + algo = algorithm.lower() + try: + if algo in hashlib.algorithms_guaranteed: + ENCODING = 'utf-8' + bytestring = string.encode(ENCODING) # Hashing functions expect bytes, not strings + if algo == 'md5': + hasher = hashlib.md5(bytestring) + elif algo == 'sha1': + hasher = hashlib.sha1(bytestring) + elif algo == 'sha224': + hasher = hashlib.sha224(bytestring) + elif algo == 'sha256': + hasher = hashlib.sha256(bytestring) + elif algo == 'sha384': + hasher = hashlib.sha384(bytestring) + elif algo == 'sha512': + hasher = hashlib.sha512(bytestring) + else: + return '' + return hasher.hexdigest() + else: + return '' + except Exception: + return '' + + +# ################################################################# +# lists the scripts, that shall be visible inside the Basic/Python IDE +# ################################################################# + +g_exportedScripts = () + +if __name__ == "__main__": + print(_SF_Platform('Architecture')) + print(_SF_Platform('ComputerName')) + print(_SF_Platform('CPUCount')) + print(_SF_Platform('CurrentUser')) + print(_SF_Platform('Machine')) + print(_SF_Platform('OSName')) + print(_SF_Platform('OSPlatform')) + print(_SF_Platform('OSRelease')) + print(_SF_Platform('OSVersion')) + print(_SF_Platform('Processor')) + print(_SF_Platform('PythonVersion')) + # + print(hashlib.algorithms_guaranteed) + print(_SF_FileSystem__HashFile('/opt/libreoffice6.4/program/libbootstraplo.so', 'md5')) + print(_SF_FileSystem__HashFile('/opt/libreoffice6.4/share/Scripts/python/Capitalise.py', 'sha512')) + # + print(_SF_String__HashStr('œ∑¡™£¢∞§¶•ªº–≠œ∑´®†¥¨ˆøπ“‘åß∂ƒ©˙∆˚¬', 'MD5')) # 616eb9c513ad07cd02924b4d285b9987 + # + # _SF_Session__OpenURLInBrowser('https://docs.python.org/3/library/webbrowser.html') + # + js = """ + {"firstName": "John","lastName": "Smith","isAlive": true,"age": 27, + "address": {"streetAddress": "21 2nd Street","city": "New York","state": "NY","postalCode": "10021-3100"}, + "phoneNumbers": [{"type": "home","number": "212 555-1234"},{"type": "office","number": "646 555-4567"}], + "children": ["Q", "M", "G", "T"],"spouse": null} + """ + arr = _SF_Dictionary__ImportFromJson(js) + print(arr) diff --git a/wizards/source/scriptforge/python/scriptforge.py b/wizards/source/scriptforge/python/scriptforge.py new file mode 100644 index 000000000..ebc6f147c --- /dev/null +++ b/wizards/source/scriptforge/python/scriptforge.py @@ -0,0 +1,2539 @@ +# -*- coding: utf-8 -*- + +# Copyright 2020-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +# ===================================================================================================================== +# === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +# === Full documentation is available on https://help.libreoffice.org/ === +# ===================================================================================================================== + +# ScriptForge is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +# ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +# 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +# distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +# 2) The GNU Lesser General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. If a copy of the LGPL was not +# distributed with this file, see http://www.gnu.org/licenses/ . + +""" + ScriptForge libraries are an extensible and robust collection of macro scripting resources for LibreOffice + to be invoked from user Basic or Python macros. Users familiar with other BASIC macro variants often face hard + times to dig into the extensive LibreOffice Application Programming Interface even for the simplest operations. + By collecting most-demanded document operations in a set of easy to use, easy to read routines, users can now + program document macros with much less hassle and get quicker results. + + ScriptForge abundant methods are organized in reusable modules that cleanly isolate Basic/Python programming + language constructs from ODF document content accesses and user interface(UI) features. + + The scriptforge.py module + - implements a protocol between Python (user) scripts and the ScriptForge Basic library + - contains the interfaces (classes and attributes) to be used in Python user scripts + to run the services implemented in the standard libraries shipped with LibreOffice + + Usage: + + When Python and LibreOffice run in the same process (usual case): either + from scriptforge import * # or, better ... + from scriptforge import CreateScriptService + + When Python and LibreOffice are started in separate processes, + LibreOffice being started from console ... (example for Linux with port = 2021) + ./soffice --accept='socket,host=localhost,port=2021;urp;' + then use next statement: + from scriptforge import * # or, better ... + from scriptforge import CreateScriptService, ScriptForge + ScriptForge(hostname = 'localhost', port = 2021) + + Specific documentation about the use of ScriptForge from Python scripts: + https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_intro.html?DbPAR=BASIC + """ + +import uno + +import datetime +import time +import os + + +class _Singleton(type): + """ + A Singleton metaclass design pattern + Credits: « Python in a Nutshell » by Alex Martelli, O'Reilly + """ + instances = {} + + def __call__(cls, *args, **kwargs): + if cls not in cls.instances: + cls.instances[cls] = super(_Singleton, cls).__call__(*args, **kwargs) + return cls.instances[cls] + + +# ##################################################################################################################### +# ScriptForge CLASS ### +# ##################################################################################################################### + +class ScriptForge(object, metaclass = _Singleton): + """ + The ScriptForge (singleton) class encapsulates the core of the ScriptForge run-time + - Bridge with the LibreOffice process + - Implementation of the inter-language protocol with the Basic libraries + - Identification of the available services interfaces + - Dispatching of services + - Coexistence with UNO + + It embeds the Service class that manages the protocol with Basic + """ + + # ######################################################################### + # Class attributes + # ######################################################################### + hostname = '' + port = 0 + componentcontext = None + scriptprovider = None + SCRIPTFORGEINITDONE = False + + # ######################################################################### + # Class constants + # ######################################################################### + library = 'ScriptForge' + Version = '7.4' # Actual version number + # + # Basic dispatcher for Python scripts + basicdispatcher = '@application#ScriptForge.SF_PythonHelper._PythonDispatcher' + # Python helper functions module + pythonhelpermodule = 'ScriptForgeHelper.py' + # + # VarType() constants + V_EMPTY, V_NULL, V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE = 0, 1, 2, 3, 4, 5 + V_CURRENCY, V_DATE, V_STRING, V_OBJECT, V_BOOLEAN = 6, 7, 8, 9, 11 + V_VARIANT, V_ARRAY, V_ERROR, V_UNO = 12, 8192, -1, 16 + # Object types + objMODULE, objCLASS, objUNO = 1, 2, 3 + # Special argument symbols + cstSymEmpty, cstSymNull, cstSymMissing = '+++EMPTY+++', '+++NULL+++', '+++MISSING+++' + # Predefined references for services implemented as standard Basic modules + servicesmodules = dict([('ScriptForge.Array', 0), + ('ScriptForge.Exception', 1), + ('ScriptForge.FileSystem', 2), + ('ScriptForge.Platform', 3), + ('ScriptForge.Region', 4), + ('ScriptForge.Services', 5), + ('ScriptForge.Session', 6), + ('ScriptForge.String', 7), + ('ScriptForge.UI', 8)]) + + def __init__(self, hostname = '', port = 0): + """ + Because singleton, constructor is executed only once while Python active + Arguments are mandatory when Python and LibreOffice run in separate processes + :param hostname: probably 'localhost' + :param port: port number + """ + ScriptForge.hostname = hostname + ScriptForge.port = port + # Determine main pyuno entry points + ScriptForge.componentcontext = self.ConnectToLOProcess(hostname, port) # com.sun.star.uno.XComponentContext + ScriptForge.scriptprovider = self.ScriptProvider(self.componentcontext) # ...script.provider.XScriptProvider + # + # Establish a list of the available services as a dictionary (servicename, serviceclass) + ScriptForge.serviceslist = dict((cls.servicename, cls) for cls in SFServices.__subclasses__()) + ScriptForge.servicesdispatcher = None + # + # All properties and methods of the ScriptForge API are ProperCased + # Compute their synonyms as lowercased and camelCased names + ScriptForge.SetAttributeSynonyms() + # + ScriptForge.SCRIPTFORGEINITDONE = True + + @classmethod + def ConnectToLOProcess(cls, hostname = '', port = 0): + """ + Called by the ScriptForge class constructor to establish the connection with + the requested LibreOffice instance + The default arguments are for the usual interactive mode + + :param hostname: probably 'localhost' or '' + :param port: port number or 0 + :return: the derived component context + """ + if len(hostname) > 0 and port > 0: # Explicit connection request via socket + ctx = uno.getComponentContext() # com.sun.star.uno.XComponentContext + resolver = ctx.ServiceManager.createInstanceWithContext( + 'com.sun.star.bridge.UnoUrlResolver', ctx) # com.sun.star.comp.bridge.UnoUrlResolver + try: + conn = 'socket,host=%s,port=%d' % (hostname, port) + url = 'uno:%s;urp;StarOffice.ComponentContext' % conn + ctx = resolver.resolve(url) + except Exception: # thrown when LibreOffice specified instance isn't started + raise SystemExit( + 'Connection to LibreOffice failed (host = ' + hostname + ', port = ' + str(port) + ')') + return ctx + elif len(hostname) == 0 and port == 0: # Usual interactive mode + return uno.getComponentContext() + else: + raise SystemExit('The creation of the ScriptForge() instance got invalid arguments: ' + + '(host = ' + hostname + ', port = ' + str(port) + ')') + + @classmethod + def ScriptProvider(cls, context = None): + """ + Returns the general script provider + """ + servicemanager = context.ServiceManager # com.sun.star.lang.XMultiComponentFactory + masterscript = servicemanager.createInstanceWithContext( + 'com.sun.star.script.provider.MasterScriptProviderFactory', context) + return masterscript.createScriptProvider("") + + @classmethod + def InvokeSimpleScript(cls, script, *args): + """ + Create a UNO object corresponding with the given Python or Basic script + The execution is done with the invoke() method applied on the created object + Implicit scope: Either + "application" a shared library (BASIC) + "share" a library of LibreOffice Macros (PYTHON) + :param script: Either + [@][scope#][library.]module.method - Must not be a class module or method + [@] means that the targeted method accepts ParamArray arguments (Basic only) + [scope#][directory/]module.py$method - Must be a method defined at module level + :return: the value returned by the invoked script, or an error if the script was not found + """ + + # The frequently called PythonDispatcher in the ScriptForge Basic library is cached to privilege performance + if cls.servicesdispatcher is not None and script == ScriptForge.basicdispatcher: + xscript = cls.servicesdispatcher + fullscript = script + paramarray = True + # Build the URI specification described in + # https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification + elif len(script) > 0: + # Check ParamArray arguments + paramarray = False + if script[0] == '@': + script = script[1:] + paramarray = True + scope = '' + if '#' in script: + scope, script = script.split('#') + if '.py$' in script.lower(): # Python + if len(scope) == 0: + scope = 'share' # Default for Python + # Provide an alternate helper script depending on test context + if script.startswith(cls.pythonhelpermodule) and hasattr(cls, 'pythonhelpermodule2'): + script = cls.pythonhelpermodule2 + script[len(cls.pythonhelpermodule):] + if '#' in script: + scope, script = script.split('#') + uri = 'vnd.sun.star.script:{0}?language=Python&location={1}'.format(script, scope) + else: # Basic + if len(scope) == 0: + scope = 'application' # Default for Basic + lib = '' + if len(script.split('.')) < 3: + lib = cls.library + '.' # Default library = ScriptForge + uri = 'vnd.sun.star.script:{0}{1}?language=Basic&location={2}'.format(lib, script, scope) + # Get the script object + fullscript = ('@' if paramarray else '') + scope + ':' + script + try: + xscript = cls.scriptprovider.getScript(uri) + except Exception: + raise RuntimeError( + 'The script \'{0}\' could not be located in your LibreOffice installation'.format(script)) + else: # Should not happen + return None + + # At 1st execution of the common Basic dispatcher, buffer xscript + if fullscript == ScriptForge.basicdispatcher and cls.servicesdispatcher is None: + cls.servicesdispatcher = xscript + + # Execute the script with the given arguments + # Packaging for script provider depends on presence of ParamArray arguments in the called Basic script + if paramarray: + scriptreturn = xscript.invoke(args[0], (), ()) + else: + scriptreturn = xscript.invoke(args, (), ()) + + # + return scriptreturn[0] # Updatable arguments passed by reference are ignored + + @classmethod + def InvokeBasicService(cls, basicobject, flags, method, *args): + """ + Execute a given Basic script and interpret its result + This method has as counterpart the ScriptForge.SF_PythonHelper._PythonDispatcher() Basic method + :param basicobject: a Service subclass + :param flags: see the vb* and flg* constants in the SFServices class + :param method: the name of the method or property to invoke, as a string + :param args: the arguments of the method. Symbolic cst* constants may be necessary + :return: The invoked Basic counterpart script (with InvokeSimpleScript()) will return a tuple + [0] The returned value - scalar, object reference or a tuple + [1] The Basic VarType() of the returned value + Null, Empty and Nothing have different vartypes but return all None to Python + Additionally, when [0] is a tuple: + [2] Number of dimensions in Basic + Additionally, when [0] is a UNO or Basic object: + [2] Module (1), Class instance (2) or UNO (3) + [3] The object's ObjectType + [4] The object's ServiceName + [5] The object's name + When an error occurs Python receives None as a scalar. This determines the occurrence of a failure + The method returns either + - the 0th element of the tuple when scalar, tuple or UNO object + - a new Service() object or one of its subclasses otherwise + """ + # Constants + script = ScriptForge.basicdispatcher + cstNoArgs = '+++NOARGS+++' + cstValue, cstVarType, cstDims, cstClass, cstType, cstService, cstName = 0, 1, 2, 2, 3, 4, 5 + + # + # Run the basic script + # The targeted script has a ParamArray argument. Do not change next 4 lines except if you know what you do ! + if len(args) == 0: + args = (basicobject,) + (flags,) + (method,) + (cstNoArgs,) + else: + args = (basicobject,) + (flags,) + (method,) + args + returntuple = cls.InvokeSimpleScript(script, args) + # + # Interpret the result + # Did an error occur in the Basic world ? + if not isinstance(returntuple, (tuple, list)): + raise RuntimeError("The execution of the method '" + method + "' failed. Execution stops.") + # + # Analyze the returned tuple + if returntuple[cstVarType] == ScriptForge.V_OBJECT and len(returntuple) > cstClass: # Avoid Nothing + if returntuple[cstClass] == ScriptForge.objUNO: + pass + else: + # Create the new class instance of the right subclass of SFServices() + servname = returntuple[cstService] + if servname not in cls.serviceslist: + # When service not found + raise RuntimeError("The service '" + servname + "' is not available in Python. Execution stops.") + subcls = cls.serviceslist[servname] + if subcls is not None: + return subcls(returntuple[cstValue], returntuple[cstType], returntuple[cstClass], + returntuple[cstName]) + elif returntuple[cstVarType] >= ScriptForge.V_ARRAY: + # Intercept empty array + if isinstance(returntuple[cstValue], uno.ByteSequence): + return () + elif returntuple[cstVarType] == ScriptForge.V_DATE: + dat = SFScriptForge.SF_Basic.CDateFromUnoDateTime(returntuple[cstValue]) + return dat + else: # All other scalar values + pass + return returntuple[cstValue] + + @staticmethod + def SetAttributeSynonyms(): + """ + A synonym of an attribute is either the lowercase or the camelCase form of its original ProperCase name. + In every subclass of SFServices: + 1) Fill the propertysynonyms dictionary with the synonyms of the properties listed in serviceproperties + Example: + serviceproperties = dict(ConfigFolder = False, InstallFolder = False) + propertysynonyms = dict(configfolder = 'ConfigFolder', installfolder = 'InstallFolder', + configFolder = 'ConfigFolder', installFolder = 'InstallFolder') + 2) Define new method attributes synonyms of the original methods + Example: + def CopyFile(...): + # etc ... + copyFile, copyfile = CopyFile, CopyFile + """ + def camelCase(key): + return key[0].lower() + key[1:] + + for cls in SFServices.__subclasses__(): + # Synonyms of properties + if hasattr(cls, 'serviceproperties'): + dico = cls.serviceproperties + dicosyn = dict(zip(map(str.lower, dico.keys()), dico.keys())) # lower case + cc = dict(zip(map(camelCase, dico.keys()), dico.keys())) # camel Case + dicosyn.update(cc) + setattr(cls, 'propertysynonyms', dicosyn) + # Synonyms of methods. A method is a public callable attribute + methods = [method for method in dir(cls) if not method.startswith('_')] + for method in methods: + func = getattr(cls, method) + if callable(func): + # Assign to each synonym a reference to the original method + lc = method.lower() + setattr(cls, lc, func) + cc = camelCase(method) + if cc != lc: + setattr(cls, cc, func) + return + + @staticmethod + def unpack_args(kwargs): + """ + Convert a dictionary passed as argument to a list alternating keys and values + Example: + dict(A = 'a', B = 2) => 'A', 'a', 'B', 2 + """ + return [v for p in zip(list(kwargs.keys()), list(kwargs.values())) for v in p] + + +# ##################################################################################################################### +# SFServices CLASS (ScriptForge services superclass) ### +# ##################################################################################################################### + +class SFServices(object): + """ + Generic implementation of a parent Service class + Every service must subclass this class to be recognized as a valid service + A service instance is created by the CreateScriptService method + It can have a mirror in the Basic world or be totally defined in Python + + Every subclass must initialize 3 class properties: + servicename (e.g. 'ScriptForge.FileSystem', 'ScriptForge.Basic') + servicesynonyms (e.g. 'FileSystem', 'Basic') + serviceimplementation: either 'python' or 'basic' + This is sufficient to register the service in the Python world + + The communication with Basic is managed by 2 ScriptForge() methods: + InvokeSimpleScript(): low level invocation of a Basic script. This script must be located + in a usual Basic module. The result is passed as-is + InvokeBasicService(): the result comes back encapsulated with additional info + The result is interpreted in the method + The invoked script can be a property or a method of a Basic class or usual module + It is up to every service method to determine which method to use + + For Basic services only: + Each instance is identified by its + - object reference: the real Basic object embedded as a UNO wrapper object + - object type ('SF_String', 'DICTIONARY', ...) + - class module: 1 for usual modules, 2 for class modules + - name (form, control, ... name) - may be blank + + The role of the SFServices() superclass is mainly to propose a generic properties management + Properties are got and set following next strategy: + 1. Property names are controlled strictly ('Value' or 'value', not 'VALUE') + 2. Getting a property value for the first time is always done via a Basic call + 3. Next occurrences are fetched from the Python dictionary of the instance if the property + is read-only, otherwise via a Basic call + 4. Read-only properties may be modified or deleted exceptionally by the class + when self.internal == True. The latter must immediately be reset after use + + Each subclass must define its interface with the user scripts: + 1. The properties + Property names are proper-cased + Conventionally, camel-cased and lower-cased synonyms are supported where relevant + a dictionary named 'serviceproperties' with keys = (proper-cased) property names and value = boolean + True = editable, False = read-only + a list named 'localProperties' reserved to properties for internal use + e.g. oDlg.Controls() is a method that uses '_Controls' to hold the list of available controls + When + forceGetProperty = False # Standard behaviour + read-only serviceproperties are buffered in Python after their 1st get request to Basic + Otherwise set it to True to force a recomputation at each property getter invocation + If there is a need to handle a specific property in a specific manner: + @property + def myProperty(self): + return self.GetProperty('myProperty') + 2 The methods + a usual def: statement + def myMethod(self, arg1, arg2 = ''): + return self.Execute(self.vbMethod, 'myMethod', arg1, arg2) + Method names are proper-cased, arguments are lower-cased + Conventionally, camel-cased and lower-cased homonyms are supported where relevant + All arguments must be present and initialized before the call to Basic, if any + """ + # Python-Basic protocol constants and flags + vbGet, vbLet, vbMethod, vbSet = 2, 4, 1, 8 # CallByName constants + flgPost = 32 # The method or the property implies a hardcoded post-processing + flgDateArg = 64 # Invoked service method may contain a date argument + flgDateRet = 128 # Invoked service method can return a date + flgArrayArg = 512 # 1st argument can be a 2D array + flgArrayRet = 1024 # Invoked service method can return a 2D array (standard modules) or any array (class modules) + flgUno = 256 # Invoked service method/property can return a UNO object + flgObject = 2048 # 1st argument may be a Basic object + flgHardCode = 4096 # Force hardcoded call to method, avoid CallByName() + # Basic class type + moduleClass, moduleStandard = 2, 1 + # + # Define the default behaviour for read-only properties: buffer their values in Python + forceGetProperty = False + # Empty dictionary for lower/camelcased homonyms or properties + propertysynonyms = {} + # To operate dynamic property getting/setting it is necessary to + # enumerate all types of properties and adapt __getattr__() and __setattr__() according to their type + internal_attributes = ('objectreference', 'objecttype', 'name', 'internal', 'servicename', + 'serviceimplementation', 'classmodule', 'EXEC', 'SIMPLEEXEC') + # Shortcuts to script provider interfaces + SIMPLEEXEC = ScriptForge.InvokeSimpleScript + EXEC = ScriptForge.InvokeBasicService + + def __init__(self, reference = -1, objtype = None, classmodule = 0, name = ''): + """ + Trivial initialization of internal properties + If the subclass has its own __init()__ method, a call to this one should be its first statement. + Afterwards localProperties should be filled with the list of its own properties + """ + self.objectreference = reference # the index in the Python storage where the Basic object is stored + self.objecttype = objtype # ('SF_String', 'DICTIONARY', ...) + self.classmodule = classmodule # Module (1), Class instance (2) + self.name = name # '' when no name + self.internal = False # True to exceptionally allow assigning a new value to a read-only property + self.localProperties = [] # the properties reserved for internal use (often empty) + + def __getattr__(self, name): + """ + Executed for EVERY property reference if name not yet in the instance dict + At the 1st get, the property value is always got from Basic + Due to the use of lower/camelcase synonyms, it is called for each variant of the same property + The method manages itself the buffering in __dict__ based on the official ProperCase property name + """ + if name in self.propertysynonyms: # Reset real name if argument provided in lower or camel case + name = self.propertysynonyms[name] + if self.serviceimplementation == 'basic': + if name in ('serviceproperties', 'localProperties', 'internal_attributes', 'propertysynonyms', + 'forceGetProperty'): + pass + elif name in self.serviceproperties: + if self.forceGetProperty is False and self.serviceproperties[name] is False: # False = read-only + if name in self.__dict__: + return self.__dict__[name] + else: + # Get Property from Basic and store it + prop = self.GetProperty(name) + self.__dict__[name] = prop + return prop + else: # Get Property from Basic and do not store it + return self.GetProperty(name) + # Execute the usual attributes getter + return super(SFServices, self).__getattribute__(name) + + def __setattr__(self, name, value): + """ + Executed for EVERY property assignment, including in __init__() !! + Setting a property requires for serviceproperties() to be executed in Basic + Management of __dict__ is automatically done in the final usual object.__setattr__ method + """ + if self.serviceimplementation == 'basic': + if name in ('serviceproperties', 'localProperties', 'internal_attributes', 'propertysynonyms', + 'forceGetProperty'): + pass + elif name[0:2] == '__' or name in self.internal_attributes or name in self.localProperties: + pass + elif name in self.serviceproperties or name in self.propertysynonyms: + if name in self.propertysynonyms: # Reset real name if argument provided in lower or camel case + name = self.propertysynonyms[name] + if self.internal: # internal = True forces property local setting even if property is read-only + pass + elif self.serviceproperties[name] is True: # True == Editable + self.SetProperty(name, value) + return + else: + raise AttributeError( + "type object '" + self.objecttype + "' has no editable property '" + name + "'") + else: + raise AttributeError("type object '" + self.objecttype + "' has no property '" + name + "'") + object.__setattr__(self, name, value) + return + + def __repr__(self): + return self.serviceimplementation + '/' + self.servicename + '/' + str(self.objectreference) + '/' + \ + super(SFServices, self).__repr__() + + def Dispose(self): + if self.serviceimplementation == 'basic': + if self.objectreference >= len(ScriptForge.servicesmodules): # Do not dispose predefined module objects + self.ExecMethod(self.vbMethod, 'Dispose') + self.objectreference = -1 + + def ExecMethod(self, flags = 0, methodname = '', *args): + if flags == 0: + flags = self.vbMethod + if len(methodname) > 0: + return self.EXEC(self.objectreference, flags, methodname, *args) + + def GetProperty(self, propertyname, arg = None): + """ + Get the given property from the Basic world + """ + if self.serviceimplementation == 'basic': + # Conventionally properties starting with X (and only them) may return a UNO object + calltype = self.vbGet + (self.flgUno if propertyname[0] == 'X' else 0) + if arg is None: + return self.EXEC(self.objectreference, calltype, propertyname) + else: # There are a few cases (Calc ...) where GetProperty accepts an argument + return self.EXEC(self.objectreference, calltype, propertyname, arg) + return None + + def Properties(self): + return list(self.serviceproperties) + + def basicmethods(self): + if self.serviceimplementation == 'basic': + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Methods') + else: + return [] + + def basicproperties(self): + if self.serviceimplementation == 'basic': + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Properties') + else: + return [] + + def SetProperty(self, propertyname, value): + """ + Set the given property to a new value in the Basic world + """ + if self.serviceimplementation == 'basic': + flag = self.vbLet + if isinstance(value, datetime.datetime): + value = SFScriptForge.SF_Basic.CDateToUnoDateTime(value) + flag += self.flgDateArg + if repr(type(value)) == "": + flag += self.flgUno + return self.EXEC(self.objectreference, flag, propertyname, value) + + +# ##################################################################################################################### +# SFScriptForge CLASS (alias of ScriptForge Basic library) ### +# ##################################################################################################################### +class SFScriptForge: + pass + + # ######################################################################### + # SF_Array CLASS + # ######################################################################### + class SF_Array(SFServices, metaclass = _Singleton): + """ + Provides a collection of methods for manipulating and transforming arrays of one dimension (vectors) + and arrays of two dimensions (matrices). This includes set operations, sorting, + importing to and exporting from text files. + The Python version of the service provides a single method: ImportFromCSVFile + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.Array' + servicesynonyms = ('array', 'scriptforge.array') + serviceproperties = dict() + + def ImportFromCSVFile(self, filename, delimiter = ',', dateformat = ''): + """ + Difference with the Basic version: dates are returned in their iso format, + not as any of the datetime objects. + """ + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'ImportFromCSVFile', + filename, delimiter, dateformat) + + # ######################################################################### + # SF_Basic CLASS + # ######################################################################### + class SF_Basic(SFServices, metaclass = _Singleton): + """ + This service proposes a collection of Basic methods to be executed in a Python context + simulating the exact syntax and behaviour of the identical Basic builtin method. + Typical example: + SF_Basic.MsgBox('This has to be displayed in a message box') + + The signatures of Basic builtin functions are derived from + core/basic/source/runtime/stdobj.cxx + + Detailed user documentation: + https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_basic.html?DbPAR=BASIC + """ + # Mandatory class properties for service registration + serviceimplementation = 'python' + servicename = 'ScriptForge.Basic' + servicesynonyms = ('basic', 'scriptforge.basic') + # Basic helper functions invocation + module = 'SF_PythonHelper' + # Message box constants + MB_ABORTRETRYIGNORE, MB_DEFBUTTON1, MB_DEFBUTTON2, MB_DEFBUTTON3 = 2, 128, 256, 512 + MB_ICONEXCLAMATION, MB_ICONINFORMATION, MB_ICONQUESTION, MB_ICONSTOP = 48, 64, 32, 16 + MB_OK, MB_OKCANCEL, MB_RETRYCANCEL, MB_YESNO, MB_YESNOCANCEL = 0, 1, 5, 4, 3 + IDABORT, IDCANCEL, IDIGNORE, IDNO, IDOK, IDRETRY, IDYES = 3, 2, 5, 7, 1, 4, 6 + + @classmethod + def CDate(cls, datevalue): + cdate = cls.SIMPLEEXEC(cls.module + '.PyCDate', datevalue) + return cls.CDateFromUnoDateTime(cdate) + + @staticmethod + def CDateFromUnoDateTime(unodate): + """ + Converts a UNO date/time representation to a datetime.datetime Python native object + :param unodate: com.sun.star.util.DateTime, com.sun.star.util.Date or com.sun.star.util.Time + :return: the equivalent datetime.datetime + """ + date = datetime.datetime(1899, 12, 30, 0, 0, 0, 0) # Idem as Basic builtin TimeSeria() function + datetype = repr(type(unodate)) + if 'com.sun.star.util.DateTime' in datetype: + if 1900 <= unodate.Year <= datetime.MAXYEAR: + date = datetime.datetime(unodate.Year, unodate.Month, unodate.Day, unodate.Hours, + unodate.Minutes, unodate.Seconds, int(unodate.NanoSeconds / 1000)) + elif 'com.sun.star.util.Date' in datetype: + if 1900 <= unodate.Year <= datetime.MAXYEAR: + date = datetime.datetime(unodate.Year, unodate.Month, unodate.Day) + elif 'com.sun.star.util.Time' in datetype: + date = datetime.datetime(unodate.Hours, unodate.Minutes, unodate.Seconds, + int(unodate.NanoSeconds / 1000)) + else: + return unodate # Not recognized as a UNO date structure + return date + + @staticmethod + def CDateToUnoDateTime(date): + """ + Converts a date representation into the ccom.sun.star.util.DateTime date format + Acceptable boundaries: year >= 1900 and <= 32767 + :param date: datetime.datetime, datetime.date, datetime.time, float (time.time) or time.struct_time + :return: a com.sun.star.util.DateTime + """ + unodate = uno.createUnoStruct('com.sun.star.util.DateTime') + unodate.Year, unodate.Month, unodate.Day, unodate.Hours, unodate.Minutes, unodate.Seconds, \ + unodate.NanoSeconds, unodate.IsUTC = \ + 1899, 12, 30, 0, 0, 0, 0, False # Identical to Basic TimeSerial() function + + if isinstance(date, float): + date = time.localtime(date) + if isinstance(date, time.struct_time): + if 1900 <= date[0] <= 32767: + unodate.Year, unodate.Month, unodate.Day, unodate.Hours, unodate.Minutes, unodate.Seconds =\ + date[0:6] + else: # Copy only the time related part + unodate.Hours, unodate.Minutes, unodate.Seconds = date[3:3] + elif isinstance(date, (datetime.datetime, datetime.date, datetime.time)): + if isinstance(date, (datetime.datetime, datetime.date)): + if 1900 <= date.year <= 32767: + unodate.Year, unodate.Month, unodate.Day = date.year, date.month, date.day + if isinstance(date, (datetime.datetime, datetime.time)): + unodate.Hours, unodate.Minutes, unodate.Seconds, unodate.NanoSeconds = \ + date.hour, date.minute, date.second, date.microsecond * 1000 + else: + return date # Not recognized as a date + return unodate + + @classmethod + def ConvertFromUrl(cls, url): + return cls.SIMPLEEXEC(cls.module + '.PyConvertFromUrl', url) + + @classmethod + def ConvertToUrl(cls, systempath): + return cls.SIMPLEEXEC(cls.module + '.PyConvertToUrl', systempath) + + @classmethod + def CreateUnoService(cls, servicename): + return cls.SIMPLEEXEC(cls.module + '.PyCreateUnoService', servicename) + + @classmethod + def DateAdd(cls, interval, number, date): + if isinstance(date, datetime.datetime): + date = cls.CDateToUnoDateTime(date) + dateadd = cls.SIMPLEEXEC(cls.module + '.PyDateAdd', interval, number, date) + return cls.CDateFromUnoDateTime(dateadd) + + @classmethod + def DateDiff(cls, interval, date1, date2, firstdayofweek = 1, firstweekofyear = 1): + if isinstance(date1, datetime.datetime): + date1 = cls.CDateToUnoDateTime(date1) + if isinstance(date2, datetime.datetime): + date2 = cls.CDateToUnoDateTime(date2) + return cls.SIMPLEEXEC(cls.module + '.PyDateDiff', interval, date1, date2, firstdayofweek, firstweekofyear) + + @classmethod + def DatePart(cls, interval, date, firstdayofweek = 1, firstweekofyear = 1): + if isinstance(date, datetime.datetime): + date = cls.CDateToUnoDateTime(date) + return cls.SIMPLEEXEC(cls.module + '.PyDatePart', interval, date, firstdayofweek, firstweekofyear) + + @classmethod + def DateValue(cls, string): + if isinstance(string, datetime.datetime): + string = string.isoformat() + datevalue = cls.SIMPLEEXEC(cls.module + '.PyDateValue', string) + return cls.CDateFromUnoDateTime(datevalue) + + @classmethod + def Format(cls, expression, format = ''): + if isinstance(expression, datetime.datetime): + expression = cls.CDateToUnoDateTime(expression) + return cls.SIMPLEEXEC(cls.module + '.PyFormat', expression, format) + + @classmethod + def GetDefaultContext(cls): + return ScriptForge.componentcontext + + @classmethod + def GetGuiType(cls): + return cls.SIMPLEEXEC(cls.module + '.PyGetGuiType') + + @classmethod + def GetPathSeparator(cls): + return os.sep + + @classmethod + def GetSystemTicks(cls): + return cls.SIMPLEEXEC(cls.module + '.PyGetSystemTicks') + + class GlobalScope(object, metaclass = _Singleton): + @classmethod # Mandatory because the GlobalScope class is normally not instantiated + def BasicLibraries(cls): + return ScriptForge.InvokeSimpleScript(SFScriptForge.SF_Basic.module + '.PyGlobalScope', 'Basic') + + @classmethod + def DialogLibraries(cls): + return ScriptForge.InvokeSimpleScript(SFScriptForge.SF_Basic.module + '.PyGlobalScope', 'Dialog') + + @classmethod + def InputBox(cls, prompt, title = '', default = '', xpostwips = -1, ypostwips = -1): + if xpostwips < 0 or ypostwips < 0: + return cls.SIMPLEEXEC(cls.module + '.PyInputBox', prompt, title, default) + return cls.SIMPLEEXEC(cls.module + '.PyInputBox', prompt, title, default, xpostwips, ypostwips) + + @classmethod + def MsgBox(cls, prompt, buttons = 0, title = ''): + return cls.SIMPLEEXEC(cls.module + '.PyMsgBox', prompt, buttons, title) + + @classmethod + def Now(cls): + return datetime.datetime.now() + + @classmethod + def RGB(cls, red, green, blue): + return int('%02x%02x%02x' % (red, green, blue), 16) + + @property + def StarDesktop(self): + ctx = ScriptForge.componentcontext + if ctx is None: + return None + smgr = ctx.getServiceManager() # com.sun.star.lang.XMultiComponentFactory + DESK = 'com.sun.star.frame.Desktop' + desktop = smgr.createInstanceWithContext(DESK, ctx) + return desktop + starDesktop, stardesktop = StarDesktop, StarDesktop + + @property + def ThisComponent(self): + """ + When the current component is the Basic IDE, the ThisComponent object returns + in Basic the component owning the currently run user script. + Above behaviour cannot be reproduced in Python. + :return: the current component or None when not a document + """ + comp = self.StarDesktop.getCurrentComponent() + if comp is None: + return None + impl = comp.ImplementationName + if impl in ('com.sun.star.comp.basic.BasicIDE', 'com.sun.star.comp.sfx2.BackingComp'): + return None # None when Basic IDE or welcome screen + return comp + thisComponent, thiscomponent = ThisComponent, ThisComponent + + @property + def ThisDatabaseDocument(self): + """ + When the current component is the Basic IDE, the ThisDatabaseDocument object returns + in Basic the database owning the currently run user script. + Above behaviour cannot be reproduced in Python. + :return: the current Base (main) component or None when not a Base document or one of its subcomponents + """ + comp = self.ThisComponent # Get the current component + if comp is None: + return None + # + sess = CreateScriptService('Session') + impl, ident = '', '' + if sess.HasUnoProperty(comp, 'ImplementationName'): + impl = comp.ImplementationName + if sess.HasUnoProperty(comp, 'Identifier'): + ident = comp.Identifier + # + targetimpl = 'com.sun.star.comp.dba.ODatabaseDocument' + if impl == targetimpl: # The current component is the main Base window + return comp + # Identify resp. form, table/query, table/query in edit mode, report, relations diagram + if impl == 'SwXTextDocument' and ident == 'com.sun.star.sdb.FormDesign' \ + or impl == 'org.openoffice.comp.dbu.ODatasourceBrowser' \ + or impl in ('org.openoffice.comp.dbu.OTableDesign', 'org.openoffice.comp.dbu.OQuertDesign') \ + or impl == 'SwXTextDocument' and ident == 'com.sun.star.sdb.TextReportDesign' \ + or impl == 'org.openoffice.comp.dbu.ORelationDesign': + db = comp.ScriptContainer + if sess.HasUnoProperty(db, 'ImplementationName'): + if db.ImplementationName == targetimpl: + return db + return None + thisDatabaseDocument, thisdatabasedocument = ThisDatabaseDocument, ThisDatabaseDocument + + @classmethod + def Xray(cls, unoobject = None): + return cls.SIMPLEEXEC('XrayTool._main.xray', unoobject) + + # ######################################################################### + # SF_Dictionary CLASS + # ######################################################################### + class SF_Dictionary(SFServices, dict): + """ + The service adds to a Python dict instance the interfaces for conversion to and from + a list of UNO PropertyValues + + Usage: + dico = dict(A = 1, B = 2, C = 3) + myDict = CreateScriptService('Dictionary', dico) # Initialize myDict with the content of dico + myDict['D'] = 4 + print(myDict) # {'A': 1, 'B': 2, 'C': 3, 'D': 4} + propval = myDict.ConvertToPropertyValues() + or + dico = dict(A = 1, B = 2, C = 3) + myDict = CreateScriptService('Dictionary') # Initialize myDict as an empty dict object + myDict.update(dico) # Load the values of dico into myDict + myDict['D'] = 4 + print(myDict) # {'A': 1, 'B': 2, 'C': 3, 'D': 4} + propval = myDict.ConvertToPropertyValues() + """ + # Mandatory class properties for service registration + serviceimplementation = 'python' + servicename = 'ScriptForge.Dictionary' + servicesynonyms = ('dictionary', 'scriptforge.dictionary') + + def __init__(self, dic = None): + SFServices.__init__(self) + dict.__init__(self) + if dic is not None: + self.update(dic) + + def ConvertToPropertyValues(self): + """ + Store the content of the dictionary in an array of PropertyValues. + Each entry in the array is a com.sun.star.beans.PropertyValue. + he key is stored in Name, the value is stored in Value. + + If one of the items has a type datetime, it is converted to a com.sun.star.util.DateTime structure. + If one of the items is an empty list, it is converted to None. + + The resulting array is empty when the dictionary is empty. + """ + result = [] + for key in iter(self): + value = self[key] + item = value + if isinstance(value, dict): # check that first level is not itself a (sub)dict + item = None + elif isinstance(value, (tuple, list)): # check every member of the list is not a (sub)dict + if len(value) == 0: # Property values do not like empty lists + value = None + else: + for i in range(len(value)): + if isinstance(value[i], dict): + value[i] = None + item = value + elif isinstance(value, (datetime.datetime, datetime.date, datetime.time)): + item = SFScriptForge.SF_Basic.CDateToUnoDateTime(value) + pv = uno.createUnoStruct('com.sun.star.beans.PropertyValue') + pv.Name = key + pv.Value = item + result.append(pv) + return result + + def ImportFromPropertyValues(self, propertyvalues, overwrite = False): + """ + Inserts the contents of an array of PropertyValue objects into the current dictionary. + PropertyValue Names are used as keys in the dictionary, whereas Values contain the corresponding values. + Date-type values are converted to datetime.datetime instances. + :param propertyvalues: a list.tuple containing com.sun.star.beans.PropertyValue objects + :param overwrite: When True, entries with same name may exist in the dictionary and their values + are overwritten. When False (default), repeated keys are not overwritten. + :return: True when successful + """ + result = [] + for pv in iter(propertyvalues): + key = pv.Name + if overwrite is True or key not in self: + item = pv.Value + if 'com.sun.star.util.DateTime' in repr(type(item)): + item = datetime.datetime(item.Year, item.Month, item.Day, + item.Hours, item.Minutes, item.Seconds, int(item.NanoSeconds / 1000)) + elif 'com.sun.star.util.Date' in repr(type(item)): + item = datetime.datetime(item.Year, item.Month, item.Day) + elif 'com.sun.star.util.Time' in repr(type(item)): + item = datetime.datetime(item.Hours, item.Minutes, item.Seconds, int(item.NanoSeconds / 1000)) + result.append((key, item)) + self.update(result) + return True + + # ######################################################################### + # SF_Exception CLASS + # ######################################################################### + class SF_Exception(SFServices, metaclass = _Singleton): + """ + The Exception service is a collection of methods for code debugging and error handling. + + The Exception service console stores events, variable values and information about errors. + Use the console when the Python shell is not available, for example in Calc user defined functions (UDF) + or during events processing. + Use DebugPrint() method to aggregate additional user data of any type. + + Console entries can be dumped to a text file or visualized in a dialogue. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.Exception' + servicesynonyms = ('exception', 'scriptforge.exception') + serviceproperties = dict() + + def Console(self, modal = True): + # From Python, the current XComponentContext must be added as last argument + return self.ExecMethod(self.vbMethod, 'Console', modal, ScriptForge.componentcontext) + + def ConsoleClear(self, keep = 0): + return self.ExecMethod(self.vbMethod, 'ConsoleClear', keep) + + def ConsoleToFile(self, filename): + return self.ExecMethod(self.vbMethod, 'ConsoleToFile', filename) + + def DebugDisplay(self, *args): + # Arguments are concatenated in a single string similar to what the Python print() function would produce + self.DebugPrint(*args) + param = '\n'.join(list(map(lambda a: a.strip("'") if isinstance(a, str) else repr(a), args))) + bas = CreateScriptService('ScriptForge.Basic') + return bas.MsgBox(param, bas.MB_OK + bas.MB_ICONINFORMATION, 'DebugDisplay') + + def DebugPrint(self, *args): + # Arguments are concatenated in a single string similar to what the Python print() function would produce + # Avoid using repr() on strings to not have backslashes * 4 + param = '\t'.join(list(map(lambda a: a.strip("'") if isinstance(a, str) else repr(a), + args))).expandtabs(tabsize = 4) + return self.ExecMethod(self.vbMethod, 'DebugPrint', param) + + @classmethod + def PythonShell(cls, variables = None): + """ + Open an APSO python shell window - Thanks to its authors Hanya/Tsutomu Uchino/Hubert Lambert + :param variables: Typical use + PythonShell.({**globals(), **locals()}) + to push the global and local dictionaries to the shell window + """ + if variables is None: + variables = locals() + # Is APSO installed ? + ctx = ScriptForge.componentcontext + ext = ctx.getByName('/singletons/com.sun.star.deployment.PackageInformationProvider') + apso = 'apso.python.script.organizer' + if len(ext.getPackageLocation(apso)) > 0: + # Directly derived from apso.oxt|python|scripts|tools.py$console + # we need to load apso before import statement + ctx.ServiceManager.createInstance('apso.python.script.organizer.impl') + # now we can use apso_utils library + from apso_utils import console + kwargs = {'loc': variables} + kwargs['loc'].setdefault('XSCRIPTCONTEXT', uno) + console(**kwargs) + # An interprocess call is necessary to allow a redirection of STDOUT and STDERR by APSO + # Choice is a minimalist call to a Basic routine: no arguments, a few lines of code + SFScriptForge.SF_Basic.GetGuiType() + else: + # The APSO extension could not be located in your LibreOffice installation + cls._RaiseFatal('SF_Exception.PythonShell', 'variables=None', 'PYTHONSHELLERROR') + + @classmethod + def RaiseFatal(cls, errorcode, *args): + """ + Generate a run-time error caused by an anomaly in a user script detected by ScriptForge + The message is logged in the console. The execution is STOPPED + For INTERNAL USE only + """ + # Direct call because RaiseFatal forces an execution stop in Basic + if len(args) == 0: + args = (None,) + return cls.SIMPLEEXEC('@SF_Exception.RaiseFatal', (errorcode, *args)) # With ParamArray + + @classmethod + def _RaiseFatal(cls, sub, subargs, errorcode, *args): + """ + Wrapper of RaiseFatal(). Includes method and syntax of the failed Python routine + to simulate the exact behaviour of the Basic RaiseFatal() method + For INTERNAL USE only + """ + ScriptForge.InvokeSimpleScript('ScriptForge.SF_Utils._EnterFunction', sub, subargs) + cls.RaiseFatal(errorcode, *args) + raise RuntimeError("The execution of the method '" + sub.split('.')[-1] + "' failed. Execution stops.") + + # ######################################################################### + # SF_FileSystem CLASS + # ######################################################################### + class SF_FileSystem(SFServices, metaclass = _Singleton): + """ + The "FileSystem" service includes common file and folder handling routines. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.FileSystem' + servicesynonyms = ('filesystem', 'scriptforge.filesystem') + serviceproperties = dict(FileNaming = True, ConfigFolder = False, ExtensionsFolder = False, HomeFolder = False, + InstallFolder = False, TemplatesFolder = False, TemporaryFolder = False, + UserTemplatesFolder = False) + # Force for each property to get its value from Basic - due to FileNaming updatability + forceGetProperty = True + # Open TextStream constants + ForReading, ForWriting, ForAppending = 1, 2, 8 + + def BuildPath(self, foldername, name): + return self.ExecMethod(self.vbMethod, 'BuildPath', foldername, name) + + def CompareFiles(self, filename1, filename2, comparecontents = False): + py = ScriptForge.pythonhelpermodule + '$' + '_SF_FileSystem__CompareFiles' + if self.FileExists(filename1) and self.FileExists(filename2): + file1 = self._ConvertFromUrl(filename1) + file2 = self._ConvertFromUrl(filename2) + return self.SIMPLEEXEC(py, file1, file2, comparecontents) + else: + return False + + def CopyFile(self, source, destination, overwrite = True): + return self.ExecMethod(self.vbMethod, 'CopyFile', source, destination, overwrite) + + def CopyFolder(self, source, destination, overwrite = True): + return self.ExecMethod(self.vbMethod, 'CopyFolder', source, destination, overwrite) + + def CreateFolder(self, foldername): + return self.ExecMethod(self.vbMethod, 'CreateFolder', foldername) + + def CreateTextFile(self, filename, overwrite = True, encoding = 'UTF-8'): + return self.ExecMethod(self.vbMethod, 'CreateTextFile', filename, overwrite, encoding) + + def DeleteFile(self, filename): + return self.ExecMethod(self.vbMethod, 'DeleteFile', filename) + + def DeleteFolder(self, foldername): + return self.ExecMethod(self.vbMethod, 'DeleteFolder', foldername) + + def ExtensionFolder(self, extension): + return self.ExecMethod(self.vbMethod, 'ExtensionFolder', extension) + + def FileExists(self, filename): + return self.ExecMethod(self.vbMethod, 'FileExists', filename) + + def Files(self, foldername, filter = ''): + return self.ExecMethod(self.vbMethod, 'Files', foldername, filter) + + def FolderExists(self, foldername): + return self.ExecMethod(self.vbMethod, 'FolderExists', foldername) + + def GetBaseName(self, filename): + return self.ExecMethod(self.vbMethod, 'GetBaseName', filename) + + def GetExtension(self, filename): + return self.ExecMethod(self.vbMethod, 'GetExtension', filename) + + def GetFileLen(self, filename): + py = ScriptForge.pythonhelpermodule + '$' + '_SF_FileSystem__GetFilelen' + if self.FileExists(filename): + file = self._ConvertFromUrl(filename) + return int(self.SIMPLEEXEC(py, file)) + else: + return 0 + + def GetFileModified(self, filename): + return self.ExecMethod(self.vbMethod + self.flgDateRet, 'GetFileModified', filename) + + def GetName(self, filename): + return self.ExecMethod(self.vbMethod, 'GetName', filename) + + def GetParentFolderName(self, filename): + return self.ExecMethod(self.vbMethod, 'GetParentFolderName', filename) + + def GetTempName(self): + return self.ExecMethod(self.vbMethod, 'GetTempName') + + def HashFile(self, filename, algorithm): + py = ScriptForge.pythonhelpermodule + '$' + '_SF_FileSystem__HashFile' + if self.FileExists(filename): + file = self._ConvertFromUrl(filename) + return self.SIMPLEEXEC(py, file, algorithm.lower()) + else: + return '' + + def MoveFile(self, source, destination): + return self.ExecMethod(self.vbMethod, 'MoveFile', source, destination) + + def MoveFolder(self, source, destination): + return self.ExecMethod(self.vbMethod, 'MoveFolder', source, destination) + + def OpenTextFile(self, filename, iomode = 1, create = False, encoding = 'UTF-8'): + return self.ExecMethod(self.vbMethod, 'OpenTextFile', filename, iomode, create, encoding) + + def PickFile(self, defaultfile = ScriptForge.cstSymEmpty, mode = 'OPEN', filter = ''): + return self.ExecMethod(self.vbMethod, 'PickFile', defaultfile, mode, filter) + + def PickFolder(self, defaultfolder = ScriptForge.cstSymEmpty, freetext = ''): + return self.ExecMethod(self.vbMethod, 'PickFolder', defaultfolder, freetext) + + def SubFolders(self, foldername, filter = ''): + return self.ExecMethod(self.vbMethod, 'SubFolders', foldername, filter) + + @classmethod + def _ConvertFromUrl(cls, filename): + # Alias for same function in FileSystem Basic module + return cls.SIMPLEEXEC('ScriptForge.SF_FileSystem._ConvertFromUrl', filename) + + # ######################################################################### + # SF_L10N CLASS + # ######################################################################### + class SF_L10N(SFServices): + """ + This service provides a number of methods related to the translation of strings + with minimal impact on the program's source code. + The methods provided by the L10N service can be used mainly to: + Create POT files that can be used as templates for translation of all strings in the program. + Get translated strings at runtime for the language defined in the Locale property. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.L10N' + servicesynonyms = ('l10n', 'scriptforge.l10n') + serviceproperties = dict(Folder = False, Languages = False, Locale = False) + + @classmethod + def ReviewServiceArgs(cls, foldername = '', locale = '', encoding = 'UTF-8', + locale2 = '', encoding2 = 'UTF-8'): + """ + Transform positional and keyword arguments into positional only + """ + return foldername, locale, encoding, locale2, encoding2 + + def AddText(self, context = '', msgid = '', comment = ''): + return self.ExecMethod(self.vbMethod, 'AddText', context, msgid, comment) + + def AddTextsFromDialog(self, dialog): + dialogobj = dialog.objectreference if isinstance(dialog, SFDialogs.SF_Dialog) else dialog + return self.ExecMethod(self.vbMethod + self.flgObject, 'AddTextsFromDialog', dialogobj) + + def ExportToPOTFile(self, filename, header = '', encoding= 'UTF-8'): + return self.ExecMethod(self.vbMethod, 'ExportToPOTFile', filename, header, encoding) + + def GetText(self, msgid, *args): + return self.ExecMethod(self.vbMethod, 'GetText', msgid, *args) + _ = GetText + + # ######################################################################### + # SF_Platform CLASS + # ######################################################################### + class SF_Platform(SFServices, metaclass = _Singleton): + """ + The 'Platform' service implements a collection of properties about the actual execution environment + and context : + the hardware platform + the operating system + the LibreOffice version + the current user + All those properties are read-only. + The implementation is mainly based on the 'platform' module of the Python standard library + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.Platform' + servicesynonyms = ('platform', 'scriptforge.platform') + serviceproperties = dict(Architecture = False, ComputerName = False, CPUCount = False, CurrentUser = False, + Extensions = False, FilterNames = False, Fonts = False, FormatLocale = False, + Locale = False, Machine = False, OfficeLocale = False, OfficeVersion = False, + OSName = False, OSPlatform = False, OSRelease = False, OSVersion = False, + Printers = False, Processor = False, PythonVersion = False, SystemLocale = False) + # Python helper functions + py = ScriptForge.pythonhelpermodule + '$' + '_SF_Platform' + + @property + def Architecture(self): + return self.SIMPLEEXEC(self.py, 'Architecture') + + @property + def ComputerName(self): + return self.SIMPLEEXEC(self.py, 'ComputerName') + + @property + def CPUCount(self): + return self.SIMPLEEXEC(self.py, 'CPUCount') + + @property + def CurrentUser(self): + return self.SIMPLEEXEC(self.py, 'CurrentUser') + + @property + def Machine(self): + return self.SIMPLEEXEC(self.py, 'Machine') + + @property + def OSName(self): + return self.SIMPLEEXEC(self.py, 'OSName') + + @property + def OSPlatform(self): + return self.SIMPLEEXEC(self.py, 'OSPlatform') + + @property + def OSRelease(self): + return self.SIMPLEEXEC(self.py, 'OSRelease') + + @property + def OSVersion(self): + return self.SIMPLEEXEC(self.py, 'OSVersion') + + @property + def Processor(self): + return self.SIMPLEEXEC(self.py, 'Processor') + + @property + def PythonVersion(self): + return self.SIMPLEEXEC(self.py, 'PythonVersion') + + # ######################################################################### + # SF_Region CLASS + # ######################################################################### + class SF_Region(SFServices, metaclass = _Singleton): + """ + The "Region" service gathers a collection of functions about languages, countries and timezones + - Locales + - Currencies + - Numbers and dates formatting + - Calendars + - Timezones conversions + - Numbers transformed to text + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.Region' + servicesynonyms = ('region', 'scriptforge.region') + serviceproperties = dict() + + # Next functions are implemented in Basic as read-only properties with 1 argument + def Country(self, region = ''): + return self.GetProperty('Country', region) + + def Currency(self, region = ''): + return self.GetProperty('Currency', region) + + def DatePatterns(self, region = ''): + return self.GetProperty('DatePatterns', region) + + def DateSeparator(self, region = ''): + return self.GetProperty('DateSeparator', region) + + def DayAbbrevNames(self, region = ''): + return self.GetProperty('DayAbbrevNames', region) + + def DayNames(self, region = ''): + return self.GetProperty('DayNames', region) + + def DayNarrowNames(self, region = ''): + return self.GetProperty('DayNarrowNames', region) + + def DecimalPoint(self, region = ''): + return self.GetProperty('DecimalPoint', region) + + def Language(self, region = ''): + return self.GetProperty('Language', region) + + def ListSeparator(self, region = ''): + return self.GetProperty('ListSeparator', region) + + def MonthAbbrevNames(self, region = ''): + return self.GetProperty('MonthAbbrevNames', region) + + def MonthNames(self, region = ''): + return self.GetProperty('MonthNames', region) + + def MonthNarrowNames(self, region = ''): + return self.GetProperty('MonthNarrowNames', region) + + def ThousandSeparator(self, region = ''): + return self.GetProperty('ThousandSeparator', region) + + def TimeSeparator(self, region = ''): + return self.GetProperty('TimeSeparator', region) + + # Usual methods + def DSTOffset(self, localdatetime, timezone, locale = ''): + if isinstance(localdatetime, datetime.datetime): + localdatetime = SFScriptForge.SF_Basic.CDateToUnoDateTime(localdatetime) + return self.ExecMethod(self.vbMethod + self.flgDateArg, 'DSTOffset', localdatetime, timezone, locale) + + def LocalDateTime(self, utcdatetime, timezone, locale = ''): + if isinstance(utcdatetime, datetime.datetime): + utcdatetime = SFScriptForge.SF_Basic.CDateToUnoDateTime(utcdatetime) + localdate = self.ExecMethod(self.vbMethod + self.flgDateArg + self.flgDateRet, 'LocalDateTime', + utcdatetime, timezone, locale) + return SFScriptForge.SF_Basic.CDateFromUnoDateTime(localdate) + + def Number2Text(self, number, locale = ''): + return self.ExecMethod(self.vbMethod, 'Number2Text', number, locale) + + def TimeZoneOffset(self, timezone, locale = ''): + return self.ExecMethod(self.vbMethod, 'TimeZoneOffset', timezone, locale) + + def UTCDateTime(self, localdatetime, timezone, locale = ''): + if isinstance(localdatetime, datetime.datetime): + localdatetime = SFScriptForge.SF_Basic.CDateToUnoDateTime(localdatetime) + utcdate = self.ExecMethod(self.vbMethod + self.flgDateArg + self.flgDateRet, 'UTCDateTime', localdatetime, + timezone, locale) + return SFScriptForge.SF_Basic.CDateFromUnoDateTime(utcdate) + + def UTCNow(self, timezone, locale = ''): + now = self.ExecMethod(self.vbMethod + self.flgDateRet, 'UTCNow', timezone, locale) + return SFScriptForge.SF_Basic.CDateFromUnoDateTime(now) + + # ######################################################################### + # SF_Session CLASS + # ######################################################################### + class SF_Session(SFServices, metaclass = _Singleton): + """ + The Session service gathers various general-purpose methods about: + - UNO introspection + - the invocation of external scripts or programs + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.Session' + servicesynonyms = ('session', 'scriptforge.session') + serviceproperties = dict() + + # Class constants Where to find an invoked library ? + SCRIPTISEMBEDDED = 'document' # in the document + SCRIPTISAPPLICATION = 'application' # in any shared library (Basic) + SCRIPTISPERSONAL = 'user' # in My Macros (Python) + SCRIPTISPERSOXT = 'user:uno_packages' # in an extension installed for the current user (Python) + SCRIPTISSHARED = 'share' # in LibreOffice macros (Python) + SCRIPTISSHAROXT = 'share:uno_packages' # in an extension installed for all users (Python) + SCRIPTISOXT = 'uno_packages' # in an extension but the installation parameters are unknown (Python) + + @classmethod + def ExecuteBasicScript(cls, scope = '', script = '', *args): + if scope is None or scope == '': + scope = cls.SCRIPTISAPPLICATION + if len(args) == 0: + args = (scope,) + (script,) + (None,) + else: + args = (scope,) + (script,) + args + # ExecuteBasicScript method has a ParamArray parameter in Basic + return cls.SIMPLEEXEC('@SF_Session.ExecuteBasicScript', args) + + @classmethod + def ExecuteCalcFunction(cls, calcfunction, *args): + if len(args) == 0: + # Arguments of Calc functions are strings or numbers. None == Empty is a good alias for no argument + args = (calcfunction,) + (None,) + else: + args = (calcfunction,) + args + # ExecuteCalcFunction method has a ParamArray parameter in Basic + return cls.SIMPLEEXEC('@SF_Session.ExecuteCalcFunction', args) + + @classmethod + def ExecutePythonScript(cls, scope = '', script = '', *args): + return cls.SIMPLEEXEC(scope + '#' + script, *args) + + def HasUnoMethod(self, unoobject, methodname): + return self.ExecMethod(self.vbMethod, 'HasUnoMethod', unoobject, methodname) + + def HasUnoProperty(self, unoobject, propertyname): + return self.ExecMethod(self.vbMethod, 'HasUnoProperty', unoobject, propertyname) + + @classmethod + def OpenURLInBrowser(cls, url): + py = ScriptForge.pythonhelpermodule + '$' + '_SF_Session__OpenURLInBrowser' + return cls.SIMPLEEXEC(py, url) + + def RunApplication(self, command, parameters): + return self.ExecMethod(self.vbMethod, 'RunApplication', command, parameters) + + def SendMail(self, recipient, cc = '', bcc = '', subject = '', body = '', filenames = '', editmessage = True): + return self.ExecMethod(self.vbMethod, 'SendMail', recipient, cc, bcc, subject, body, filenames, editmessage) + + def UnoObjectType(self, unoobject): + return self.ExecMethod(self.vbMethod, 'UnoObjectType', unoobject) + + def UnoMethods(self, unoobject): + return self.ExecMethod(self.vbMethod, 'UnoMethods', unoobject) + + def UnoProperties(self, unoobject): + return self.ExecMethod(self.vbMethod, 'UnoProperties', unoobject) + + def WebService(self, uri): + return self.ExecMethod(self.vbMethod, 'WebService', uri) + + # ######################################################################### + # SF_String CLASS + # ######################################################################### + class SF_String(SFServices, metaclass = _Singleton): + """ + Focus on string manipulation, regular expressions, encodings and hashing algorithms. + The methods implemented in Basic that are redundant with Python builtin functions + are not duplicated + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.String' + servicesynonyms = ('string', 'scriptforge.string') + serviceproperties = dict() + + @classmethod + def HashStr(cls, inputstr, algorithm): + py = ScriptForge.pythonhelpermodule + '$' + '_SF_String__HashStr' + return cls.SIMPLEEXEC(py, inputstr, algorithm.lower()) + + def IsADate(self, inputstr, dateformat = 'YYYY-MM-DD'): + return self.ExecMethod(self.vbMethod, 'IsADate', inputstr, dateformat) + + def IsEmail(self, inputstr): + return self.ExecMethod(self.vbMethod, 'IsEmail', inputstr) + + def IsFileName(self, inputstr, osname = ScriptForge.cstSymEmpty): + return self.ExecMethod(self.vbMethod, 'IsFileName', inputstr, osname) + + def IsIBAN(self, inputstr): + return self.ExecMethod(self.vbMethod, 'IsIBAN', inputstr) + + def IsIPv4(self, inputstr): + return self.ExecMethod(self.vbMethod, 'IsIPv4', inputstr) + + def IsLike(self, inputstr, pattern, casesensitive = False): + return self.ExecMethod(self.vbMethod, 'IsLike', inputstr, pattern, casesensitive) + + def IsSheetName(self, inputstr): + return self.ExecMethod(self.vbMethod, 'IsSheetName', inputstr) + + def IsUrl(self, inputstr): + return self.ExecMethod(self.vbMethod, 'IsUrl', inputstr) + + def SplitNotQuoted(self, inputstr, delimiter = ' ', occurrences = 0, quotechar = '"'): + return self.ExecMethod(self.vbMethod, 'SplitNotQuoted', inputstr, delimiter, occurrences, quotechar) + + def Wrap(self, inputstr, width = 70, tabsize = 8): + return self.ExecMethod(self.vbMethod, 'Wrap', inputstr, width, tabsize) + + # ######################################################################### + # SF_TextStream CLASS + # ######################################################################### + class SF_TextStream(SFServices): + """ + The TextStream service is used to sequentially read from and write to files opened or created + using the ScriptForge.FileSystem service.. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.TextStream' + servicesynonyms = () + serviceproperties = dict(AtEndOfStream = False, Encoding = False, FileName = False, IOMode = False, + Line = False, NewLine = True) + + @property + def AtEndOfStream(self): + return self.GetProperty('AtEndOfStream') + atEndOfStream, atendofstream = AtEndOfStream, AtEndOfStream + + @property + def Line(self): + return self.GetProperty('Line') + line = Line + + def CloseFile(self): + return self.ExecMethod(self.vbMethod, 'CloseFile') + + def ReadAll(self): + return self.ExecMethod(self.vbMethod, 'ReadAll') + + def ReadLine(self): + return self.ExecMethod(self.vbMethod, 'ReadLine') + + def SkipLine(self): + return self.ExecMethod(self.vbMethod, 'SkipLine') + + def WriteBlankLines(self, lines): + return self.ExecMethod(self.vbMethod, 'WriteBlankLines', lines) + + def WriteLine(self, line): + return self.ExecMethod(self.vbMethod, 'WriteLine', line) + + # ######################################################################### + # SF_Timer CLASS + # ######################################################################### + class SF_Timer(SFServices): + """ + The "Timer" service measures the amount of time it takes to run user scripts. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.Timer' + servicesynonyms = ('timer', 'scriptforge.timer') + serviceproperties = dict(Duration = False, IsStarted = False, IsSuspended = False, + SuspendDuration = False, TotalDuration = False) + # Force for each property to get its value from Basic + forceGetProperty = True + + @classmethod + def ReviewServiceArgs(cls, start = False): + """ + Transform positional and keyword arguments into positional only + """ + return (start,) + + def Continue(self): + return self.ExecMethod(self.vbMethod, 'Continue') + + def Restart(self): + return self.ExecMethod(self.vbMethod, 'Restart') + + def Start(self): + return self.ExecMethod(self.vbMethod, 'Start') + + def Suspend(self): + return self.ExecMethod(self.vbMethod, 'Suspend') + + def Terminate(self): + return self.ExecMethod(self.vbMethod, 'Terminate') + + # ######################################################################### + # SF_UI CLASS + # ######################################################################### + class SF_UI(SFServices, metaclass = _Singleton): + """ + Singleton class for the identification and the manipulation of the + different windows composing the whole LibreOffice application: + - Windows selection + - Windows moving and resizing + - Statusbar settings + - Creation of new windows + - Access to the underlying "documents" + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'ScriptForge.UI' + servicesynonyms = ('ui', 'scriptforge.ui') + serviceproperties = dict(ActiveWindow = False, Height = False, Width = False, X = False, Y = False) + + # Class constants + MACROEXECALWAYS, MACROEXECNEVER, MACROEXECNORMAL = 2, 1, 0 + BASEDOCUMENT, CALCDOCUMENT, DRAWDOCUMENT, IMPRESSDOCUMENT, MATHDOCUMENT, WRITERDOCUMENT = \ + 'Base', 'Calc', 'Draw', 'Impress', 'Math', 'Writer' + + @property + def ActiveWindow(self): + return self.ExecMethod(self.vbMethod, 'ActiveWindow') + activeWindow, activewindow = ActiveWindow, ActiveWindow + + def Activate(self, windowname = ''): + return self.ExecMethod(self.vbMethod, 'Activate', windowname) + + def CreateBaseDocument(self, filename, embeddeddatabase = 'HSQLDB', registrationname = '', calcfilename = ''): + return self.ExecMethod(self.vbMethod, 'CreateBaseDocument', filename, embeddeddatabase, registrationname, + calcfilename) + + def CreateDocument(self, documenttype = '', templatefile = '', hidden = False): + return self.ExecMethod(self.vbMethod, 'CreateDocument', documenttype, templatefile, hidden) + + def Documents(self): + return self.ExecMethod(self.vbMethod, 'Documents') + + def GetDocument(self, windowname = ''): + return self.ExecMethod(self.vbMethod, 'GetDocument', windowname) + + def Maximize(self, windowname = ''): + return self.ExecMethod(self.vbMethod, 'Maximize', windowname) + + def Minimize(self, windowname = ''): + return self.ExecMethod(self.vbMethod, 'Minimize', windowname) + + def OpenBaseDocument(self, filename = '', registrationname = '', macroexecution = MACROEXECNORMAL): + return self.ExecMethod(self.vbMethod, 'OpenBaseDocument', filename, registrationname, macroexecution) + + def OpenDocument(self, filename, password = '', readonly = False, hidden = False, + macroexecution = MACROEXECNORMAL, filtername = '', filteroptions = ''): + return self.ExecMethod(self.vbMethod, 'OpenDocument', filename, password, readonly, hidden, + macroexecution, filtername, filteroptions) + + def Resize(self, left = -1, top = -1, width = -1, height = -1): + return self.ExecMethod(self.vbMethod, 'Resize', left, top, width, height) + + def RunCommand(self, command, *args, **kwargs): + params = tuple(list(args) + ScriptForge.unpack_args(kwargs)) + if len(params) == 0: + params = (command,) + (None,) + else: + params = (command,) + params + return self.SIMPLEEXEC('@SF_UI.RunCommand', params) + + def SetStatusbar(self, text = '', percentage = -1): + return self.ExecMethod(self.vbMethod, 'SetStatusbar', text, percentage) + + def ShowProgressBar(self, title = '', text = '', percentage = -1): + # From Python, the current XComponentContext must be added as last argument + return self.ExecMethod(self.vbMethod, 'ShowProgressBar', title, text, percentage, + ScriptForge.componentcontext) + + def WindowExists(self, windowname): + return self.ExecMethod(self.vbMethod, 'WindowExists', windowname) + + +# ##################################################################################################################### +# SFDatabases CLASS (alias of SFDatabases Basic library) ### +# ##################################################################################################################### +class SFDatabases: + """ + The SFDatabases class manages databases embedded in or connected to Base documents + """ + pass + + # ######################################################################### + # SF_Database CLASS + # ######################################################################### + class SF_Database(SFServices): + """ + Each instance of the current class represents a single database, with essentially its tables, queries + and data + The exchanges with the database are done in SQL only. + To make them more readable, use optionally square brackets to surround table/query/field names + instead of the (RDBMS-dependent) normal surrounding character. + SQL statements may be run in direct or indirect mode. In direct mode the statement is transferred literally + without syntax checking nor review to the database engine. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDatabases.Database' + servicesynonyms = ('database', 'sfdatabases.database') + serviceproperties = dict(Queries = False, Tables = False, XConnection = False, XMetaData = False) + + @classmethod + def ReviewServiceArgs(cls, filename = '', registrationname = '', readonly = True, user = '', password = ''): + """ + Transform positional and keyword arguments into positional only + """ + return filename, registrationname, readonly, user, password + + def CloseDatabase(self): + return self.ExecMethod(self.vbMethod, 'CloseDatabase') + + def DAvg(self, expression, tablename, criteria = ''): + return self.ExecMethod(self.vbMethod, 'DAvg', expression, tablename, criteria) + + def DCount(self, expression, tablename, criteria = ''): + return self.ExecMethod(self.vbMethod, 'DCount', expression, tablename, criteria) + + def DLookup(self, expression, tablename, criteria = '', orderclause = ''): + return self.ExecMethod(self.vbMethod, 'DLookup', expression, tablename, criteria, orderclause) + + def DMax(self, expression, tablename, criteria = ''): + return self.ExecMethod(self.vbMethod, 'DMax', expression, tablename, criteria) + + def DMin(self, expression, tablename, criteria = ''): + return self.ExecMethod(self.vbMethod, 'DMin', expression, tablename, criteria) + + def DSum(self, expression, tablename, criteria = ''): + return self.ExecMethod(self.vbMethod, 'DSum', expression, tablename, criteria) + + def GetRows(self, sqlcommand, directsql = False, header = False, maxrows = 0): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'GetRows', sqlcommand, directsql, header, maxrows) + + def RunSql(self, sqlcommand, directsql = False): + return self.ExecMethod(self.vbMethod, 'RunSql', sqlcommand, directsql) + + +# ##################################################################################################################### +# SFDialogs CLASS (alias of SFDialogs Basic library) ### +# ##################################################################################################################### +class SFDialogs: + """ + The SFDialogs class manages dialogs defined with the Basic IDE + """ + pass + + # ######################################################################### + # SF_Dialog CLASS + # ######################################################################### + class SF_Dialog(SFServices): + """ + Each instance of the current class represents a single dialog box displayed to the user. + The dialog box must have been designed and defined with the Basic IDE previously. + From a Python script, a dialog box can be displayed in modal or in non-modal modes. + + In modal mode, the box is displayed and the execution of the macro process is suspended + until one of the OK or Cancel buttons is pressed. In the meantime, other user actions + executed on the box can trigger specific actions. + + In non-modal mode, the floating dialog remains displayed until the dialog is terminated + by code (Terminate()) or until the LibreOffice application stops. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDialogs.Dialog' + servicesynonyms = ('dialog', 'sfdialogs.dialog') + serviceproperties = dict(Caption = True, Height = True, Modal = False, Name = False, + OnFocusGained = False, OnFocusLost = False, OnKeyPressed = False, + OnKeyReleased = False, OnMouseDragged = False, OnMouseEntered = False, + OnMouseExited = False, OnMouseMoved = False, OnMousePressed = False, + OnMouseReleased = False, + Page = True, Visible = True, Width = True, XDialogModel = False, XDialogView = False) + # Class constants used together with the Execute() method + OKBUTTON, CANCELBUTTON = 1, 0 + + @classmethod + def ReviewServiceArgs(cls, container = '', library = 'Standard', dialogname = ''): + """ + Transform positional and keyword arguments into positional only + Add the XComponentContext as last argument + """ + return container, library, dialogname, ScriptForge.componentcontext + + # Methods potentially executed while the dialog is in execution require the flgHardCode flag + def Activate(self): + return self.ExecMethod(self.vbMethod + self.flgHardCode, 'Activate') + + def Center(self, parent = ScriptForge.cstSymMissing): + parentclasses = (SFDocuments.SF_Document, SFDocuments.SF_Base, SFDocuments.SF_Calc, SFDocuments.SF_Writer, + SFDialogs.SF_Dialog) + parentobj = parent.objectreference if isinstance(parent, parentclasses) else parent + return self.ExecMethod(self.vbMethod + self.flgObject + self.flgHardCode, 'Center', parentobj) + + def Controls(self, controlname = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet + self.flgHardCode, 'Controls', controlname) + + def EndExecute(self, returnvalue): + return self.ExecMethod(self.vbMethod + self.flgHardCode, 'EndExecute', returnvalue) + + def Execute(self, modal = True): + return self.ExecMethod(self.vbMethod + self.flgHardCode, 'Execute', modal) + + def GetTextsFromL10N(self, l10n): + l10nobj = l10n.objectreference if isinstance(l10n, SFScriptForge.SF_L10N) else l10n + return self.ExecMethod(self.vbMethod + self.flgObject, 'GetTextsFromL10N', l10nobj) + + def Resize(self, left = -1, top = -1, width = -1, height = -1): + return self.ExecMethod(self.vbMethod + self.flgHardCode, 'Resize', left, top, width, height) + + def Terminate(self): + return self.ExecMethod(self.vbMethod, 'Terminate') + + # ######################################################################### + # SF_DialogControl CLASS + # ######################################################################### + class SF_DialogControl(SFServices): + """ + Each instance of the current class represents a single control within a dialog box. + The focus is clearly set on getting and setting the values displayed by the controls of the dialog box, + not on their formatting. + A special attention is given to controls with type TreeControl. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDialogs.DialogControl' + servicesynonyms = () + serviceproperties = dict(Cancel = True, Caption = True, ControlType = False, CurrentNode = True, + Default = True, Enabled = True, Format = True, ListCount = False, + ListIndex = True, Locked = True, MultiSelect = True, Name = False, + OnActionPerformed = False, OnAdjustmentValueChanged = False, OnFocusGained = False, + OnFocusLost = False, OnItemStateChanged = False, OnKeyPressed = False, + OnKeyReleased = False, OnMouseDragged = False, OnMouseEntered = False, + OnMouseExited = False, OnMouseMoved = False, OnMousePressed = False, + OnMouseReleased = False, OnNodeExpanded = True, OnNodeSelected = True, + OnTextChanged = False, Page = True, Parent = False, Picture = True, + RootNode = False, RowSource = True, Text = False, TipText = True, + TripleState = True, Value = True, Visible = True, + XControlModel = False, XControlView = False, XGridColumnModel = False, + XGridDataModel = False, XTreeDataModel = False) + + # Root related properties do not start with X and, nevertheless, return a UNO object + @property + def CurrentNode(self): + return self.EXEC(self.objectreference, self.vbGet + self.flgUno, 'CurrentNode') + + @property + def RootNode(self): + return self.EXEC(self.objectreference, self.vbGet + self.flgUno, 'RootNode') + + def AddSubNode(self, parentnode, displayvalue, datavalue = ScriptForge.cstSymEmpty): + return self.ExecMethod(self.vbMethod + self.flgUno, 'AddSubNode', parentnode, displayvalue, datavalue) + + def AddSubTree(self, parentnode, flattree, withdatavalue = False): + return self.ExecMethod(self.vbMethod, 'AddSubTree', parentnode, flattree, withdatavalue) + + def CreateRoot(self, displayvalue, datavalue = ScriptForge.cstSymEmpty): + return self.ExecMethod(self.vbMethod + self.flgUno, 'CreateRoot', displayvalue, datavalue) + + def FindNode(self, displayvalue, datavalue = ScriptForge.cstSymEmpty, casesensitive = False): + return self.ExecMethod(self.vbMethod + self.flgUno, 'FindNode', displayvalue, datavalue, casesensitive) + + def SetFocus(self): + return self.ExecMethod(self.vbMethod, 'SetFocus') + + def SetTableData(self, dataarray, widths = (1,), alignments = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayArg, 'SetTableData', dataarray, widths, alignments) + + def WriteLine(self, line = ''): + return self.ExecMethod(self.vbMethod, 'WriteLine', line) + + +# ##################################################################################################################### +# SFDocuments CLASS (alias of SFDocuments Basic library) ### +# ##################################################################################################################### +class SFDocuments: + """ + The SFDocuments class gathers a number of classes, methods and properties making easy + managing and manipulating LibreOffice documents + """ + pass + + # ######################################################################### + # SF_Document CLASS + # ######################################################################### + class SF_Document(SFServices): + """ + The methods and properties are generic for all types of documents: they are combined in the + current SF_Document class + - saving, closing documents + - accessing their standard or custom properties + Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ... + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.Document' + servicesynonyms = ('document', 'sfdocuments.document') + serviceproperties = dict(Description = True, DocumentType = False, ExportFilters = False, ImportFilters = False, + IsBase = False, IsCalc = False, IsDraw = False, IsImpress = False, IsMath = False, + IsWriter = False, Keywords = True, Readonly = False, Subject = True, Title = True, + XComponent = False) + # Force for each property to get its value from Basic - due to intense interactivity with user + forceGetProperty = True + + @classmethod + def ReviewServiceArgs(cls, windowname = ''): + """ + Transform positional and keyword arguments into positional only + """ + return windowname, + + def Activate(self): + return self.ExecMethod(self.vbMethod, 'Activate') + + def CloseDocument(self, saveask = True): + return self.ExecMethod(self.vbMethod, 'CloseDocument', saveask) + + def CreateMenu(self, menuheader, before = '', submenuchar = '>'): + return self.ExecMethod(self.vbMethod, 'CreateMenu', menuheader, before, submenuchar) + + def ExportAsPDF(self, filename, overwrite = False, pages = '', password = '', watermark = ''): + return self.ExecMethod(self.vbMethod, 'ExportAsPDF', filename, overwrite, pages, password, watermark) + + def PrintOut(self, pages = '', copies = 1): + return self.ExecMethod(self.vbMethod, 'PrintOut', pages, copies) + + def RemoveMenu(self, menuheader): + return self.ExecMethod(self.vbMethod, 'RemoveMenu', menuheader) + + def RunCommand(self, command, *args, **kwargs): + params = tuple([command] + list(args) + ScriptForge.unpack_args(kwargs)) + return self.ExecMethod(self.vbMethod, 'RunCommand', *params) + + def Save(self): + return self.ExecMethod(self.vbMethod, 'Save') + + def SaveAs(self, filename, overwrite = False, password = '', filtername = '', filteroptions = ''): + return self.ExecMethod(self.vbMethod, 'SaveAs', filename, overwrite, password, filtername, filteroptions) + + def SaveCopyAs(self, filename, overwrite = False, password = '', filtername = '', filteroptions = ''): + return self.ExecMethod(self.vbMethod, 'SaveCopyAs', filename, overwrite, + password, filtername, filteroptions) + + def SetPrinter(self, printer = '', orientation = '', paperformat = ''): + return self.ExecMethod(self.vbMethod, 'SetPrinter', printer, orientation, paperformat) + + # ######################################################################### + # SF_Base CLASS + # ######################################################################### + class SF_Base(SF_Document, SFServices): + """ + The SF_Base module is provided mainly to block parent properties that are NOT applicable to Base documents + In addition, it provides methods to identify form documents and access their internal forms + (read more elsewhere (the "SFDocuments.Form" service) about this subject) + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.Base' + servicesynonyms = ('base', 'scriptforge.base') + serviceproperties = dict(DocumentType = False, IsBase = False, IsCalc = False, + IsDraw = False, IsImpress = False, IsMath = False, IsWriter = False, + XComponent = False) + + @classmethod + def ReviewServiceArgs(cls, windowname = ''): + """ + Transform positional and keyword arguments into positional only + """ + return windowname, + + def CloseDocument(self, saveask = True): + return self.ExecMethod(self.vbMethod, 'CloseDocument', saveask) + + def CloseFormDocument(self, formdocument): + return self.ExecMethod(self.vbMethod, 'CloseFormDocument', formdocument) + + def FormDocuments(self): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'FormDocuments') + + def Forms(self, formdocument, form = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Forms', formdocument, form) + + def GetDatabase(self, user = '', password = ''): + return self.ExecMethod(self.vbMethod, 'GetDatabase', user, password) + + def IsLoaded(self, formdocument): + return self.ExecMethod(self.vbMethod, 'IsLoaded', formdocument) + + def OpenFormDocument(self, formdocument, designmode = False): + return self.ExecMethod(self.vbMethod, 'OpenFormDocument', formdocument, designmode) + + def PrintOut(self, formdocument, pages = '', copies = 1): + return self.ExecMethod(self.vbMethod, 'PrintOut', formdocument, pages, copies) + + def SetPrinter(self, formdocument = '', printer = '', orientation = '', paperformat = ''): + return self.ExecMethod(self.vbMethod, 'SetPrinter', formdocument, printer, orientation, paperformat) + + # ######################################################################### + # SF_Calc CLASS + # ######################################################################### + class SF_Calc(SF_Document, SFServices): + """ + The SF_Calc module is focused on : + - management (copy, insert, move, ...) of sheets within a Calc document + - exchange of data between Basic data structures and Calc ranges of values + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.Calc' + servicesynonyms = ('calc', 'sfdocuments.calc') + serviceproperties = dict(CurrentSelection = True, Sheets = False, + Description = True, DocumentType = False, ExportFilters = False, ImportFilters = False, + IsBase = False, IsCalc = False, IsDraw = False, IsImpress = False, IsMath = False, + IsWriter = False, Keywords = True, Readonly = False, Subject = True, Title = True, + XComponent = False) + # Force for each property to get its value from Basic - due to intense interactivity with user + forceGetProperty = True + + @classmethod + def ReviewServiceArgs(cls, windowname = ''): + """ + Transform positional and keyword arguments into positional only + """ + return windowname, + + # Next functions are implemented in Basic as read-only properties with 1 argument + def FirstCell(self, rangename): + return self.GetProperty('FirstCell', rangename) + + def FirstColumn(self, rangename): + return self.GetProperty('FirstColumn', rangename) + + def FirstRow(self, rangename): + return self.GetProperty('FirstRow', rangename) + + def Height(self, rangename): + return self.GetProperty('Height', rangename) + + def LastCell(self, rangename): + return self.GetProperty('LastCell', rangename) + + def LastColumn(self, rangename): + return self.GetProperty('LastColumn', rangename) + + def LastRow(self, rangename): + return self.GetProperty('LastRow', rangename) + + def Range(self, rangename): + return self.GetProperty('Range', rangename) + + def Region(self, rangename): + return self.GetProperty('Region', rangename) + + def Sheet(self, sheetname): + return self.GetProperty('Sheet', sheetname) + + def SheetName(self, rangename): + return self.GetProperty('SheetName', rangename) + + def Width(self, rangename): + return self.GetProperty('Width', rangename) + + def XCellRange(self, rangename): + return self.ExecMethod(self.vbGet + self.flgUno, 'XCellRange', rangename) + + def XSheetCellCursor(self, rangename): + return self.ExecMethod(self.vbGet + self.flgUno, 'XSheetCellCursor', rangename) + + def XSpreadsheet(self, sheetname): + return self.ExecMethod(self.vbGet + self.flgUno, 'XSpreadsheet', sheetname) + + # Usual methods + def A1Style(self, row1, column1, row2 = 0, column2 = 0, sheetname = '~'): + return self.ExecMethod(self.vbMethod, 'A1Style', row1, column1, row2, column2, sheetname) + + def Activate(self, sheetname = ''): + return self.ExecMethod(self.vbMethod, 'Activate', sheetname) + + def Charts(self, sheetname, chartname = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Charts', sheetname, chartname) + + def ClearAll(self, range): + return self.ExecMethod(self.vbMethod, 'ClearAll', range) + + def ClearFormats(self, range): + return self.ExecMethod(self.vbMethod, 'ClearFormats', range) + + def ClearValues(self, range): + return self.ExecMethod(self.vbMethod, 'ClearValues', range) + + def CompactLeft(self, range, wholecolumn = False, filterformula = ''): + return self.ExecMethod(self.vbMethod, 'CompactLeft', range, wholecolumn, filterformula) + + def CompactUp(self, range, wholerow = False, filterformula = ''): + return self.ExecMethod(self.vbMethod, 'CompactUp', range, wholerow, filterformula) + + def CopySheet(self, sheetname, newname, beforesheet = 32768): + sheet = (sheetname.objectreference if isinstance(sheetname, SFDocuments.SF_CalcReference) else sheetname) + return self.ExecMethod(self.vbMethod + self.flgObject, 'CopySheet', sheet, newname, beforesheet) + + def CopySheetFromFile(self, filename, sheetname, newname, beforesheet = 32768): + sheet = (sheetname.objectreference if isinstance(sheetname, SFDocuments.SF_CalcReference) else sheetname) + return self.ExecMethod(self.vbMethod + self.flgObject, 'CopySheetFromFile', + filename, sheet, newname, beforesheet) + + def CopyToCell(self, sourcerange, destinationcell): + range = (sourcerange.objectreference if isinstance(sourcerange, SFDocuments.SF_CalcReference) + else sourcerange) + return self.ExecMethod(self.vbMethod + self.flgObject, 'CopyToCell', range, destinationcell) + + def CopyToRange(self, sourcerange, destinationrange): + range = (sourcerange.objectreference if isinstance(sourcerange, SFDocuments.SF_CalcReference) + else sourcerange) + return self.ExecMethod(self.vbMethod + self.flgObject, 'CopyToRange', range, destinationrange) + + def CreateChart(self, chartname, sheetname, range, columnheader = False, rowheader = False): + return self.ExecMethod(self.vbMethod, 'CreateChart', chartname, sheetname, range, columnheader, rowheader) + + def CreatePivotTable(self, pivottablename, sourcerange, targetcell, datafields = ScriptForge.cstSymEmpty, + rowfields = ScriptForge.cstSymEmpty, columnfields = ScriptForge.cstSymEmpty, + filterbutton = True, rowtotals = True, columntotals = True): + return self.ExecMethod(self.vbMethod, 'CreatePivotTable', pivottablename, sourcerange, targetcell, + datafields, rowfields, columnfields, filterbutton, rowtotals, columntotals) + + def DAvg(self, range): + return self.ExecMethod(self.vbMethod, 'DAvg', range) + + def DCount(self, range): + return self.ExecMethod(self.vbMethod, 'DCount', range) + + def DMax(self, range): + return self.ExecMethod(self.vbMethod, 'DMax', range) + + def DMin(self, range): + return self.ExecMethod(self.vbMethod, 'DMin', range) + + def DSum(self, range): + return self.ExecMethod(self.vbMethod, 'DSum', range) + + def ExportRangeToFile(self, range, filename, imagetype = 'pdf', overwrite = False): + return self.ExecMethod(self.vbMethod, 'ExportRangeToFile', range, filename, imagetype, overwrite) + + def Forms(self, sheetname, form = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Forms', sheetname, form) + + def GetColumnName(self, columnnumber): + return self.ExecMethod(self.vbMethod, 'GetColumnName', columnnumber) + + def GetFormula(self, range): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'GetFormula', range) + + def GetValue(self, range): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'GetValue', range) + + def ImportFromCSVFile(self, filename, destinationcell, filteroptions = ScriptForge.cstSymEmpty): + return self.ExecMethod(self.vbMethod, 'ImportFromCSVFile', filename, destinationcell, filteroptions) + + def ImportFromDatabase(self, filename = '', registrationname = '', destinationcell = '', sqlcommand = '', + directsql = False): + return self.ExecMethod(self.vbMethod, 'ImportFromDatabase', filename, registrationname, + destinationcell, sqlcommand, directsql) + + def InsertSheet(self, sheetname, beforesheet = 32768): + return self.ExecMethod(self.vbMethod, 'InsertSheet', sheetname, beforesheet) + + def MoveRange(self, source, destination): + return self.ExecMethod(self.vbMethod, 'MoveRange', source, destination) + + def MoveSheet(self, sheetname, beforesheet = 32768): + return self.ExecMethod(self.vbMethod, 'MoveSheet', sheetname, beforesheet) + + def Offset(self, range, rows = 0, columns = 0, height = ScriptForge.cstSymEmpty, + width = ScriptForge.cstSymEmpty): + return self.ExecMethod(self.vbMethod, 'Offset', range, rows, columns, height, width) + + def OpenRangeSelector(self, title = '', selection = '~', singlecell = False, closeafterselect = True): + return self.ExecMethod(self.vbMethod, 'OpenRangeSelector', title, selection, singlecell, closeafterselect) + + def Printf(self, inputstr, range, tokencharacter = '%'): + return self.ExecMethod(self.vbMethod, 'Printf', inputstr, range, tokencharacter) + + def PrintOut(self, sheetname = '~', pages = '', copies = 1): + return self.ExecMethod(self.vbMethod, 'PrintOut', sheetname, pages, copies) + + def RemoveSheet(self, sheetname): + return self.ExecMethod(self.vbMethod, 'RemoveSheet', sheetname) + + def RenameSheet(self, sheetname, newname): + return self.ExecMethod(self.vbMethod, 'RenameSheet', sheetname, newname) + + def SetArray(self, targetcell, value): + return self.ExecMethod(self.vbMethod + self.flgArrayArg, 'SetArray', targetcell, value) + + def SetCellStyle(self, targetrange, style): + return self.ExecMethod(self.vbMethod, 'SetCellStyle', targetrange, style) + + def SetFormula(self, targetrange, formula): + return self.ExecMethod(self.vbMethod + self.flgArrayArg, 'SetFormula', targetrange, formula) + + def SetValue(self, targetrange, value): + return self.ExecMethod(self.vbMethod + self.flgArrayArg, 'SetValue', targetrange, value) + + def ShiftDown(self, range, wholerow = False, rows = 0): + return self.ExecMethod(self.vbMethod, 'ShiftDown', range, wholerow, rows) + + def ShiftLeft(self, range, wholecolumn = False, columns = 0): + return self.ExecMethod(self.vbMethod, 'ShiftLeft', range, wholecolumn, columns) + + def ShiftRight(self, range, wholecolumn = False, columns = 0): + return self.ExecMethod(self.vbMethod, 'ShiftRight', range, wholecolumn, columns) + + def ShiftUp(self, range, wholerow = False, rows = 0): + return self.ExecMethod(self.vbMethod, 'ShiftUp', range, wholerow, rows) + + def SortRange(self, range, sortkeys, sortorder = 'ASC', destinationcell = ScriptForge.cstSymEmpty, + containsheader = False, casesensitive = False, sortcolumns = False): + return self.ExecMethod(self.vbMethod, 'SortRange', range, sortkeys, sortorder, destinationcell, + containsheader, casesensitive, sortcolumns) + + # ######################################################################### + # SF_CalcReference CLASS + # ######################################################################### + class SF_CalcReference(SFServices): + """ + The SF_CalcReference class has as unique role to hold sheet and range references. + They are implemented in Basic as Type ... End Type data structures + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.CalcReference' + servicesynonyms = () + serviceproperties = dict() + + # ######################################################################### + # SF_Chart CLASS + # ######################################################################### + class SF_Chart(SFServices): + """ + The SF_Chart module is focused on the description of chart documents + stored in Calc sheets. + With this service, many chart types and chart characteristics available + in the user interface can be read or modified. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.Chart' + servicesynonyms = () + serviceproperties = dict(ChartType = True, Deep = True, Dim3D = True, Exploded = True, Filled = True, + Legend = True, Percent = True, Stacked = True, Title = True, + XChartObj = False, XDiagram = False, XShape = False, XTableChart = False, + XTitle = True, YTitle = True) + + def Resize(self, xpos = -1, ypos = -1, width = -1, height = -1): + return self.ExecMethod(self.vbMethod, 'Resize', xpos, ypos, width, height) + + def ExportToFile(self, filename, imagetype = 'png', overwrite = False): + return self.ExecMethod(self.vbMethod, 'ExportToFile', filename, imagetype, overwrite) + + # ######################################################################### + # SF_Form CLASS + # ######################################################################### + class SF_Form(SFServices): + """ + Management of forms defined in LibreOffice documents. Supported types are Base, Calc and Writer documents. + It includes the management of subforms + Each instance of the current class represents a single form or a single subform + A form may optionally be (understand "is often") linked to a data source manageable with + the SFDatabases.Database service. The current service offers a rapid access to that service. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.Form' + servicesynonyms = () + serviceproperties = dict(AllowDeletes = True, AllowInserts = True, AllowUpdates = True, BaseForm = False, + Bookmark = True, CurrentRecord = True, Filter = True, LinkChildFields = False, + LinkParentFields = False, Name = False, + OnApproveCursorMove = True, OnApproveParameter = True, OnApproveReset = True, + OnApproveRowChange = True, OnApproveSubmit = True, OnConfirmDelete = True, + OnCursorMoved = True, OnErrorOccurred = True, OnLoaded = True, OnReloaded = True, + OnReloading = True, OnResetted = True, OnRowChanged = True, OnUnloaded = True, + OnUnloading = True, + OrderBy = True, Parent = False, RecordSource = True, XForm = False) + + def Activate(self): + return self.ExecMethod(self.vbMethod, 'Activate') + + def CloseFormDocument(self): + return self.ExecMethod(self.vbMethod, 'CloseFormDocument') + + def Controls(self, controlname = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Controls', controlname) + + def GetDatabase(self, user = '', password = ''): + return self.ExecMethod(self.vbMethod, 'GetDatabase', user, password) + + def MoveFirst(self): + return self.ExecMethod(self.vbMethod, 'MoveFirst') + + def MoveLast(self): + return self.ExecMethod(self.vbMethod, 'MoveLast') + + def MoveNew(self): + return self.ExecMethod(self.vbMethod, 'MoveNew') + + def MoveNext(self, offset = 1): + return self.ExecMethod(self.vbMethod, 'MoveNext', offset) + + def MovePrevious(self, offset = 1): + return self.ExecMethod(self.vbMethod, 'MovePrevious', offset) + + def Requery(self): + return self.ExecMethod(self.vbMethod, 'Requery') + + def Subforms(self, subform = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Subforms', subform) + + # ######################################################################### + # SF_FormControl CLASS + # ######################################################################### + class SF_FormControl(SFServices): + """ + Manage the controls belonging to a form or subform stored in a document. + Each instance of the current class represents a single control within a form, a subform or a tablecontrol. + A prerequisite is that all controls within the same form, subform or tablecontrol must have + a unique name. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.FormControl' + servicesynonyms = () + serviceproperties = dict(Action = True, Caption = True, ControlSource = False, ControlType = False, + Default = True, DefaultValue = True, Enabled = True, Format = True, + ListCount = False, ListIndex = True, ListSource = True, ListSourceType = True, + Locked = True, MultiSelect = True, Name = False, + OnActionPerformed = True, OnAdjustmentValueChanged = True, + OnApproveAction = True, OnApproveReset = True, OnApproveUpdate = True, + OnChanged = True, OnErrorOccurred = True, OnFocusGained = True, OnFocusLost = True, + OnItemStateChanged = True, OnKeyPressed = True, OnKeyReleased = True, + OnMouseDragged = True, OnMouseEntered = True, OnMouseExited = True, + OnMouseMoved = True, OnMousePressed = True, OnMouseReleased = True, OnResetted = True, + OnTextChanged = True, OnUpdated = True, Parent = False, Picture = True, + Required = True, Text = False, TipText = True, TripleState = True, Value = True, + Visible = True, XControlModel = False, XControlView = False) + + def Controls(self, controlname = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Controls', controlname) + + def SetFocus(self): + return self.ExecMethod(self.vbMethod, 'SetFocus') + + # ######################################################################### + # SF_Writer CLASS + # ######################################################################### + class SF_Writer(SF_Document, SFServices): + """ + The SF_Writer module is focused on : + - TBD + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFDocuments.Writer' + servicesynonyms = ('writer', 'sfdocuments.writer') + serviceproperties = dict(Description = True, DocumentType = False, ExportFilters = False, ImportFilters = False, + IsBase = False, IsCalc = False, IsDraw = False, IsImpress = False, IsMath = False, + IsWriter = False, Keywords = True, Readonly = False, Subject = True, Title = True, + XComponent = False) + # Force for each property to get its value from Basic - due to intense interactivity with user + forceGetProperty = True + + @classmethod + def ReviewServiceArgs(cls, windowname = ''): + """ + Transform positional and keyword arguments into positional only + """ + return windowname, + + def Forms(self, form = ''): + return self.ExecMethod(self.vbMethod + self.flgArrayRet, 'Forms', form) + + def PrintOut(self, pages = '', copies = 1, printbackground = True, printblankpages = False, + printevenpages = True, printoddpages = True, printimages = True): + return self.ExecMethod(self.vbMethod, 'PrintOut', pages, copies, printbackground, printblankpages, + printevenpages, printoddpages, printimages) + + +# ##################################################################################################################### +# SFWidgets CLASS (alias of SFWidgets Basic library) ### +# ##################################################################################################################### +class SFWidgets: + """ + The SFWidgets class manages toolbars and popup menus + """ + pass + + # ######################################################################### + # SF_Menu CLASS + # ######################################################################### + class SF_Menu(SFServices): + """ + Display a menu in the menubar of a document or a form document. + After use, the menu will not be saved neither in the application settings, nor in the document. + The menu will be displayed, as usual, when its header in the menubar is clicked. + When one of its items is selected, there are 3 alternative options: + - a UNO command (like ".uno:About") is triggered + - a user script is run receiving a standard argument defined in this service + - one of above combined with a toggle of the status of the item + The menu is described from top to bottom. Each menu item receives a numeric and a string identifier. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFWidgets.Menu' + servicesynonyms = ('menu', 'sfwidgets.menu') + serviceproperties = dict(ShortcutCharacter = False, SubmenuCharacter = False) + + def AddCheckBox(self, menuitem, name = '', status = False, icon = '', tooltip = '', + command = '', script = ''): + return self.ExecMethod(self.vbMethod, 'AddCheckBox', menuitem, name, status, icon, tooltip, + command, script) + + def AddItem(self, menuitem, name = '', icon = '', tooltip = '', command = '', script = ''): + return self.ExecMethod(self.vbMethod, 'AddItem', menuitem, name, icon, tooltip, command, script) + + def AddRadioButton(self, menuitem, name = '', status = False, icon = '', tooltip = '', + command = '', script = ''): + return self.ExecMethod(self.vbMethod, 'AddRadioButton', menuitem, name, status, icon, tooltip, + command, script) + + # ######################################################################### + # SF_PopupMenu CLASS + # ######################################################################### + class SF_PopupMenu(SFServices): + """ + Display a popup menu anywhere and any time. + A popup menu is usually triggered by a mouse action (typically a right-click) on a dialog, a form + or one of their controls. In this case the menu will be displayed below the clicked area. + When triggered by other events, including in the normal flow of a user script, the script should + provide the coordinates of the topleft edge of the menu versus the actual component. + The menu is described from top to bottom. Each menu item receives a numeric and a string identifier. + The execute() method returns the item selected by the user. + """ + # Mandatory class properties for service registration + serviceimplementation = 'basic' + servicename = 'SFWidgets.PopupMenu' + servicesynonyms = ('popupmenu', 'sfwidgets.popupmenu') + serviceproperties = dict(ShortcutCharacter = False, SubmenuCharacter = False) + + @classmethod + def ReviewServiceArgs(cls, event = None, x = 0, y = 0, submenuchar = ''): + """ + Transform positional and keyword arguments into positional only + """ + return event, x, y, submenuchar + + def AddCheckBox(self, menuitem, name = '', status = False, icon = '', tooltip = ''): + return self.ExecMethod(self.vbMethod, 'AddCheckBox', menuitem, name, status, icon, tooltip) + + def AddItem(self, menuitem, name = '', icon = '', tooltip = ''): + return self.ExecMethod(self.vbMethod, 'AddItem', menuitem, name, icon, tooltip) + + def AddRadioButton(self, menuitem, name = '', status = False, icon = '', tooltip = ''): + return self.ExecMethod(self.vbMethod, 'AddRadioButton', menuitem, name, status, icon, tooltip) + + def Execute(self, returnid = True): + return self.ExecMethod(self.vbMethod, 'Execute', returnid) + + +# ##############################################False################################################################## +# CreateScriptService() ### +# ##################################################################################################################### +def CreateScriptService(service, *args, **kwargs): + """ + A service being the name of a collection of properties and methods, + this method returns either + - the Python object mirror of the Basic object implementing the requested service + - the Python object implementing the service itself + + A service may be designated by its official name, stored in its class.servicename + or by one of its synonyms stored in its class.servicesynonyms list + If the service is not identified, the service creation is delegated to Basic, that might raise an error + if still not identified there + + :param service: the name of the service as a string 'library.service' - cased exactly + or one of its synonyms + :param args: the arguments to pass to the service constructor + :return: the service as a Python object + """ + # Init at each CreateScriptService() invocation + # CreateScriptService is usually the first statement in user scripts requesting ScriptForge services + # ScriptForge() is optional in user scripts when Python process inside LibreOffice process + if ScriptForge.SCRIPTFORGEINITDONE is False: + ScriptForge() + + def ResolveSynonyms(servicename): + """ + Synonyms within service names implemented in Python or predefined are resolved here + :param servicename: The short name of the service + :return: The official service name if found, the argument otherwise + """ + for cls in SFServices.__subclasses__(): + if servicename.lower() in cls.servicesynonyms: + return cls.servicename + return servicename + + # + # Check the list of available services + scriptservice = ResolveSynonyms(service) + if scriptservice in ScriptForge.serviceslist: + serv = ScriptForge.serviceslist[scriptservice] + # Check if the requested service is within the Python world + if serv.serviceimplementation == 'python': + return serv(*args) + # Check if the service is a predefined standard Basic service + elif scriptservice in ScriptForge.servicesmodules: + return serv(ScriptForge.servicesmodules[scriptservice], classmodule = SFServices.moduleStandard) + else: + serv = None + # The requested service is to be found in the Basic world + # Check if the service must review the arguments + if serv is not None: + if hasattr(serv, 'ReviewServiceArgs'): + # ReviewServiceArgs() must be a class method + args = serv.ReviewServiceArgs(*args, **kwargs) + # Get the service object back from Basic + if len(args) == 0: + serv = ScriptForge.InvokeBasicService('SF_Services', SFServices.vbMethod, 'CreateScriptService', service) + else: + serv = ScriptForge.InvokeBasicService('SF_Services', SFServices.vbMethod, 'CreateScriptService', + service, *args) + return serv + + +createScriptService, createscriptservice = CreateScriptService, CreateScriptService + + +# ###################################################################### +# Lists the scripts, that shall be visible inside the Basic/Python IDE +# ###################################################################### + +g_exportedScripts = () diff --git a/wizards/source/scriptforge/script.xlb b/wizards/source/scriptforge/script.xlb new file mode 100644 index 000000000..dc625046f --- /dev/null +++ b/wizards/source/scriptforge/script.xlb @@ -0,0 +1,23 @@ + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/sfdatabases/SF_Database.xba b/wizards/source/sfdatabases/SF_Database.xba new file mode 100644 index 000000000..804084aff --- /dev/null +++ b/wizards/source/sfdatabases/SF_Database.xba @@ -0,0 +1,825 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDatabases library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Database +''' ========= +''' Management of databases embedded in or related to Base documents +''' Each instance of the current class represents a single database, with essentially its tables, queries and data +''' +''' The exchanges with the database are done in SQL only. +''' To make them more readable, use optionally square brackets to surround table/query/field names +''' instead of the (RDBMS-dependent) normal surrounding character (usually, double-quote, single-quote or other). +''' SQL statements may be run in direct or indirect mode. In direct mode the statement is transferred literally +''' without syntax checking nor review to the database system. +''' +''' The provided interfaces include simple tables, queries and fields lists, and access to database metadata. +''' +''' Service invocation and usage: +''' 1) To access any database at anytime +''' Dim myDatabase As Object +''' Set myDatabase = CreateScriptService("SFDatabases.Database", FileName, , [ReadOnly], [User, [Password]]) +''' ' Args: +''' ' FileName: the name of the Base file compliant with the SF_FileSystem.FileNaming notation +''' ' RegistrationName: the name of a registered database (mutually exclusive with FileName) +''' ' ReadOnly: Default = True +''' ' User, Password: additional connection arguments to the database server +''' ' ... Run queries, SQL statements, ... +''' myDatabase.CloseDatabase() +''' +''' 2) To access the database related to the current Base document +''' Dim myDoc As Object, myDatabase As Object, ui As Object +''' Set ui = CreateScriptService("UI") +''' Set myDoc = ui.OpenBaseDocument("myDb.odb") +''' Set myDatabase = myDoc.GetDatabase() ' user and password are supplied here, if needed +''' ' ... Run queries, SQL statements, ... +''' myDoc.CloseDocument() +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_database.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DBREADONLYERROR = "DBREADONLYERROR" +Private Const SQLSYNTAXERROR = "SQLSYNTAXERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be DATABASE +Private ServiceName As String +Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource +Private _Connection As Object ' com.sun.star.sdbc.XConnection +Private _URL As String ' Text on status bar +Private _Location As String ' File name +Private _ReadOnly As Boolean +Private _MetaData As Object ' com.sun.star.sdbc.XDatabaseMetaData + +REM ============================================================ MODULE CONSTANTS + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DATABASE" + ServiceName = "SFDatabases.Database" + Set _DataSource = Nothing + Set _Connection = Nothing + _URL = "" + _Location = "" + _ReadOnly = True + Set _MetaData = Nothing +End Sub ' SFDatabases.SF_Database Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDatabases.SF_Database Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDatabases.SF_Database Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Queries() As Variant +''' Return the list of available queries in the database + Queries = _PropertyGet("Queries") +End Property ' SFDatabases.SF_Database.Queries (get) + +REM ----------------------------------------------------------------------------- +Property Get Tables() As Variant +''' Return the list of available Tables in the database + Tables = _PropertyGet("Tables") +End Property ' SFDatabases.SF_Database.Tables (get) + +REM ----------------------------------------------------------------------------- +Property Get XConnection() As Variant +''' Return a com.sun.star.sdbc.XConnection UNO object + XConnection = _PropertyGet("XConnection") +End Property ' SFDatabases.SF_Database.XConnection (get) + +REM ----------------------------------------------------------------------------- +Property Get XMetaData() As Variant +''' Return a com.sun.star.sdbc.XDatabaseMetaData UNO object + XMetaData = _PropertyGet("XMetaData") +End Property ' SFDatabases.SF_Database.XMetaData (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Sub CloseDatabase() +''' Close the current database connection + +Const cstThisSub = "SFDatabases.Database.CloseDatabase" +Const cstSubArgs = "" + + On Local Error GoTo 0 ' Disable useless error checking + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + +Try: + With _Connection + If Not IsNull(_Connection) Then + If ScriptForge.SF_Session.HasUnoMethod(_Connection, "flush") Then .flush() + .close() + .dispose() + End If + Dispose() + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub + +REM ----------------------------------------------------------------------------- +Public Function DAvg(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function AVG() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DAvg = _DFunction("Avg", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DAvg + +REM ----------------------------------------------------------------------------- +Public Function DCount(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function COUNT() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DCount = _DFunction("Count", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DCount + +REM ----------------------------------------------------------------------------- +Public Function DLookup(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + , Optional ByVal OrderClause As Variant _ + ) As Variant +''' Compute the aggregate function Lookup() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' To order the results, a pvOrderClause may be precised. The 1st record will be retained. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE +''' pvOrderClause: an optional order clause incl. "DESC" if relevant + + DLookup = _DFunction("Lookup", Expression, TableName, Criteria, OrderClause) + +End Function ' SFDatabases.SF_Database.DLookup + +REM ----------------------------------------------------------------------------- +Public Function DMax(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function MAX() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DMax = _DFunction("Max", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DMax + +REM ----------------------------------------------------------------------------- +Public Function DMin(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function MIN() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DMin = _DFunction("Min", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DMin + +REM ----------------------------------------------------------------------------- +Public Function DSum(Optional ByVal Expression As Variant _ + , Optional ByVal TableName As Variant _ + , Optional ByVal Criteria As Variant _ + ) As Variant +''' Compute the aggregate function Sum() on a field or expression belonging to a table +''' filtered by a WHERE-clause. +''' Args: +''' Expression: an SQL expression +''' TableName: the name of a table +''' Criteria: an optional WHERE clause without the word WHERE + + DSum = _DFunction("Sum", Expression, TableName, Criteria) + +End Function ' SFDatabases.SF_Database.DSum + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myDatabase.GetProperty("Queries") + +Const cstThisSub = "SFDatabases.Database.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetRows(Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + , Optional ByVal Header As Variant _ + , Optional ByVal MaxRows As Variant _ + ) As Variant +''' Return the content of a table, a query or a SELECT SQL statement as an array +''' Args: +''' SQLCommand: a table name, a query name or a SELECT SQL statement +''' DirectSQL: when True, no syntax conversion is done by LO. Default = False +''' Ignored when SQLCommand is a table or a query name +''' Header: When True, a header row is inserted on the top of the array with the column names. Default = False +''' MaxRows: The maximum number of returned rows. If absent, all records are returned +''' Returns: +''' a 2D array(row, column), even if only 1 column and/or 1 record +''' an empty array if no records returned +''' Example: +''' Dim a As Variant +''' a = myDatabase.GetRows("SELECT [First Name], [Last Name] FROM [Employees] ORDER BY [Last Name]", Header := True) + +Dim vResult As Variant ' Return value +Dim oResult As Object ' com.sun.star.sdbc.XResultSet +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim sSql As String ' SQL statement +Dim bDirect ' Alias of DirectSQL +Dim lCols As Long ' Number of columns +Dim lRows As Long ' Number of rows +Dim oColumns As Object +Dim i As Long +Const cstThisSub = "SFDatabases.Database.GetRows" +Const cstSubArgs = "SQLCommand, [DirectSQL=False], [Header=False], [MaxRows=0]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vResult = Array() + +Check: + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If IsMissing(Header) Or IsEmpty(Header) Then Header = False + If IsMissing(MaxRows) Or IsEmpty(MaxRows) Then MaxRows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Table, query of SQL ? Prepare resultset + If ScriptForge.SF_Array.Contains(Tables, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + sSql = "SELECT * FROM [" & SQLCommand & "]" + bDirect = True + ElseIf ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + Set oQuery = _Connection.Queries.getByName(SQLCommand) + sSql = oQuery.Command + bDirect = Not oQuery.EscapeProcessing + ElseIf ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then + sSql = SQLCommand + bDirect = DirectSQL + Else + GoTo Finally + End If + + ' Execute command + Set oResult = _ExecuteSql(sSql, bDirect) + If IsNull(oResult) Then GoTo Finally + + With oResult + 'Initialize output array with header row + Set oColumns = oResult.getColumns() + lCols = oColumns.Count - 1 + If Header Then + lRows = 0 + ReDim vResult(0 To lRows, 0 To lCols) + For i = 0 To lCols + vResult(lRows, i) = oColumns.getByIndex(i).Name + Next i + If MaxRows > 0 Then MaxRows = MaxRows + 1 + Else + lRows = -1 + End If + + ' Load data + .first() + Do While Not .isAfterLast() And (MaxRows = 0 Or lRows < MaxRows - 1) + lRows = lRows + 1 + If lRows = 0 Then + ReDim vResult(0 To lRows, 0 To lCols) + Else + ReDim Preserve vResult(0 To lRows, 0 To lCols) + End If + For i = 0 To lCols + vResult(lRows, i) = _GetColumnValue(oResult, i + 1) + Next i + .next() + Loop + End With + +Finally: + GetRows = vResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.GetRows + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Database service as an array + + Methods = Array( _ + "CloseDatabase" _ + , "DAvg" _ + , "DCount" _ + , "DLookup" _ + , "DMax" _ + , "DMin" _ + , "DSum" _ + , "GetRows" _ + , "RunSql" _ + ) + +End Function ' SFDatabases.SF_Database.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Database class as an array + + Properties = Array( _ + "Queries" _ + , "Tables" _ + , "XConnection" _ + , "XMetaData" _ + ) + +End Function ' SFDatabases.SF_Database.Properties + +REM ----------------------------------------------------------------------------- +Public Function RunSql(Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + ) As Boolean +''' Execute an action query (table creation, record insertion, ...) or SQL statement on the current database +''' Args: +''' SQLCommand: a query name or an SQL statement +''' DirectSQL: when True, no syntax conversion is done by LO. Default = False +''' Ignored when SQLCommand is a query name +''' Exceptions: +''' DBREADONLYERROR The method is not applicable on a read-only database +''' Example: +''' myDatabase.RunSql("INSERT INTO [EMPLOYEES] VALUES(25, 'SMITH', 'John')", DirectSQL := True) + +Dim bResult As Boolean ' Return value +Dim oStatement As Object ' com.sun.star.sdbc.XStatement +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim sSql As String ' SQL statement +Dim bDirect ' Alias of DirectSQL +Const cstQuery = 2, cstSql = 3 +Const cstThisSub = "SFDatabases.Database.RunSql" +Const cstSubArgs = "SQLCommand, [DirectSQL=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bResult = False + +Check: + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + If _ReadOnly Then GoTo Catch_ReadOnly + +Try: + ' Query of SQL ? + If ScriptForge.SF_Array.Contains(Queries, SQLCommand, CaseSensitive := True, SortOrder := "ASC") Then + Set oQuery = _Connection.Queries.getByName(SQLCommand) + sSql = oQuery.Command + bDirect = Not oQuery.EscapeProcessing + ElseIf Not ScriptForge.SF_String.StartsWith(SQLCommand, "SELECT", CaseSensitive := False) Then + sSql = SQLCommand + bDirect = DirectSQL + Else + GoTo Finally + End If + + ' Execute command + bResult = _ExecuteSql(sSql, bDirect) + +Finally: + RunSql = bResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +Catch_ReadOnly: + ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR) + GoTo Finally +End Function ' SFDatabases.SF_Database.RunSql + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDatabases.Database.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DFunction(ByVal psFunction As String _ + , Optional ByVal pvExpression As Variant _ + , Optional ByVal pvTableName As Variant _ + , Optional ByVal pvCriteria As Variant _ + , Optional ByVal pvOrderClause As Variant _ + ) As Variant +''' Build and execute a SQL statement computing the aggregate function psFunction +''' on a field or expression pvExpression belonging to a table pvTableName +''' filtered by a WHERE-clause pvCriteria. +''' To order the results, a pvOrderClause may be precised. +''' Only the 1st record will be retained anyway. +''' Args: +''' psFunction an optional aggregate function: SUM, COUNT, AVG, LOOKUP +''' pvExpression: an SQL expression +''' pvTableName: the name of a table, NOT surrounded with quoting char +''' pvCriteria: an optional WHERE clause without the word WHERE +''' pvOrderClause: an optional order clause incl. "DESC" if relevant +''' (meaningful only for LOOKUP) + +Dim vResult As Variant ' Return value +Dim oResult As Object ' com.sun.star.sdbc.XResultSet +Dim sSql As String ' SQL statement. +Dim sExpr As String ' For inclusion of aggregate function +Dim sTarget as String ' Alias of pvExpression +Dim sWhere As String ' Alias of pvCriteria +Dim sOrderBy As String ' Alias of pvOrderClause +Dim sLimit As String ' TOP 1 clause +Dim sProductName As String ' RDBMS as a string +Const cstAliasField = "[" & "TMP_ALIAS_ANY_FIELD" & "]" ' Alias field in SQL expression +Dim cstThisSub As String : cstThisSub = "SFDatabases.SF_Database.D" & psFunction +Const cstSubArgs = "Expression, TableName, [Criteria=""""], [OrderClause=""""]" +Const cstLookup = "Lookup" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vResult = Null + +Check: + If IsMissing(pvCriteria) Or IsEmpty(pvCriteria) Then pvCriteria = "" + If IsMissing(pvOrderClause) Or IsEmpty(pvOrderClause) Then pvOrderClause = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(pvExpression, "Expression", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvTableName, "TableName", V_STRING, Tables) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvCriteria, "Criteria", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvOrderClause, "OrderClause", V_STRING) Then GoTo Finally + End If + +Try: + If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = "" + If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = "" + sLimit = "" + + pvTableName = "[" & pvTableName & "]" + + sProductName = UCase(_MetaData.getDatabaseProductName()) + + Select Case sProductName + Case "MYSQL", "SQLITE" + If psFunction = cstLookup Then + sTarget = pvExpression + sLimit = " LIMIT 1" + Else + sTarget = UCase(psFunction) & "(" & pvExpression & ")" + End If + sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & psTableName & sWhere & sOrderBy & sLimit + Case "FIREBIRD (ENGINE12)" + If psFunction = cstLookup Then sTarget = "FIRST 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")" + sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy + Case Else ' Standard syntax - Includes HSQLDB + If psFunction = cstLookup Then sTarget = "TOP 1 " & pvExpression Else sTarget = UCase(psFunction) & "(" & pvExpression & ")" + sSql = "SELECT " & sTarget & " AS " & cstAliasField & " FROM " & pvTableName & sWhere & sOrderBy + End Select + + ' Execute the SQL statement and retain the first column of the first record + Set oResult = _ExecuteSql(sSql, True) + If Not IsNull(oResult) And Not IsEmpty(oResult) Then + If Not oResult.first() Then Goto Finally + If oResult.isAfterLast() Then GoTo Finally + vResult = _GetColumnValue(oResult, 1, True) ' Force return of binary field + End If + Set oResult = Nothing + +Finally: + _DFunction = vResult + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database._DFunction + +REM ----------------------------------------------------------------------------- +Private Function _ExecuteSql(ByVal psSql As String _ + , ByVal pbDirect As Boolean _ + ) As Variant +''' Return a read-only Resultset based on a SELECT SQL statement or execute the given action SQL (INSERT, CREATE TABLE, ...) +''' The method raises a fatal error when the SQL statement cannot be interpreted +''' Args: +''' psSql : the SQL statement. Square brackets are replaced by the correct field surrounding character +''' pbDirect: when True, no syntax conversion is done by LO. Default = False +''' Exceptions +''' SQLSYNTAXERROR The given SQL statement is incorrect + +Dim vResult As Variant ' Return value - com.sun.star.sdbc.XResultSet or Boolean +Dim oStatement As Object ' com.sun.star.sdbc.XStatement +Dim sSql As String ' Alias of psSql +Dim bSelect As Boolean ' True when SELECT statement +Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements + + Set vResult = Nothing + bErrorHandler = ScriptForge.SF_Utils._ErrorHandling() + If bErrorHandler Then On Local Error GoTo Catch + +Try: + sSql = _ReplaceSquareBrackets(psSql) + bSelect = ScriptForge.SF_String.StartsWith(sSql, "SELECT", CaseSensitive := False) + + Set oStatement = _Connection.createStatement() + With oStatement + If bSelect Then + .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + End If + .EscapeProcessing = Not pbDirect + + ' Setup the result set + If bErrorHandler Then On Local Error GoTo Catch_Sql + If bSelect Then Set vResult = .executeQuery(sSql) Else vResult = .execute(sSql) + End With + +Finally: + _ExecuteSql = vResult + Set oStatement = Nothing + Exit Function +Catch_Sql: + ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAXERROR, sSql) + GoTo Finally +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database._ExecuteSql + +REM ----------------------------------------------------------------------------- +Private Function _GetColumnValue(ByRef poResultSet As Object _ + , ByVal plColIndex As Long _ + , Optional ByVal pbReturnBinary As Boolean _ + ) As Variant +''' Get the data stored in the current record of a result set in a given column +''' The type of the column is found in the resultset's metadata +''' Args: +''' poResultSet: com.sun.star.sdbc.XResultSet +''' plColIndex: the index of the column to extract the value from +''' pbReturnBinary: when True, the method returns the content of a binary field, +''' as long as its length does not exceed a maximum length. +''' Default = False: binary fields are not returned, only their length +''' Returns: +''' The Variant value found in the column +''' Dates and times are returned as Basic dates +''' Null values are returned as Null +''' Errors or strange data types are returned as Null as well + +Dim vValue As Variant ' Return value +Dim lType As Long ' SQL column type: com.sun.star.sdbc.DataType +Dim vDateTime As Variant ' com.sun.star.util.DateTime +Dim oStream As Object ' Long character or binary streams +Dim bNullable As Boolean ' The field is defined as accepting Null values +Dim lSize As Long ' Binary field length + +Const cstMaxBinlength = 2 * 65535 + + On Local Error Goto 0 ' Disable error handler + vValue = Null ' Default value if error + If IsMissing(pbReturnBinary) Then pbReturnBinary = False + + With com.sun.star.sdbc.DataType + lType = poResultSet.MetaData.getColumnType(plColIndex) + bNullable = ( poResultSet.MetaData.IsNullable(plColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + + Select Case lType + Case .ARRAY : vValue = poResultSet.getArray(plColIndex) + Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB + Set oStream = poResultSet.getBinaryStream(plColIndex) + If bNullable Then + If Not poResultSet.wasNull() Then + If Not ScriptForge.SF_Session.HasUNOMethod(oStream, "getLength") Then ' When no recordset + lSize = cstMaxBinLength + Else + lSize = CLng(oValue.getLength()) + End If + If lSize <= cstMaxBinLength And pbReturnBinary Then + vValue = Array() + oValue.readBytes(vValue, lSize) + Else ' Return length of field, not content + vValue = lSize + End If + End If + End If + oValue.closeInput() + Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(plColIndex) + Case .DATE + vDateTime = poResultSet.getDate(plColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) + Case .DISTINCT, .OBJECT, .OTHER, .STRUCT + vValue = Null + Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(plColIndex) + Case .FLOAT : vValue = poResultSet.getFloat(plColIndex) + Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(plColIndex) + Case .BIGINT : vValue = CLng(poResultSet.getLong(plColIndex)) + Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(plColIndex) + Case .SQLNULL : vValue = poResultSet.getNull(plColIndex) + Case .OBJECT, .OTHER, .STRUCT : vValue = Null + Case .REF : vValue = poResultSet.getRef(plColIndex) + Case .TINYINT : vValue = poResultSet.getShort(plColIndex) + Case .CHAR, .VARCHAR : vValue = poResultSet.getString(plColIndex) + Case .LONGVARCHAR, .CLOB + If bNullable Then + If Not poResultSet.wasNull() Then vValue = poResultSet.getString(plColIndex) + Else + vValue = "" + End If + Case .TIME + vDateTime = poResultSet.getTime(plColIndex) + If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case .TIMESTAMP + vDateTime = poResultSet.getTimeStamp(plColIndex) + If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _ + + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case Else + vValue = poResultSet.getString(plColIndex) 'GIVE STRING A TRY + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + If bNullable Then + If poResultSet.wasNull() Then vValue = Null + End If + End With + + _GetColumnValue = vValue + +End Function ' SFDatabases.SF_Database.GetColumnValue + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDatabases.Database.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case psProperty + Case "Queries" + If Not IsNull(_Connection) Then _PropertyGet = _Connection.Queries.getElementNames() Else _PropertyGet = Array() + Case "Tables" + If Not IsNull(_Connection) Then _PropertyGet = _Connection.Tables.getElementNames() Else _PropertyGet = Array() + Case "XConnection" + Set _PropertyGet = _Connection + Case "XMetaData" + Set _PropertyGet = _MetaData + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Database._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _ReplaceSquareBrackets(ByVal psSql As String) As String +''' Returns the input SQL command after replacement of square brackets by the table/field names quoting character + +Dim sSql As String ' Return value +Dim sQuote As String ' RDBMS specific table/field surrounding character +Dim sConstQuote As String ' Delimiter for string constants in SQL - usually the single quote +Const cstDouble = """" : Const cstSingle = "'" + +Try: + sQuote = _MetaData.IdentifierQuoteString + sConstQuote = Iif(sQuote = cstSingle, cstDouble, cstSingle) + + ' Replace the square brackets + sSql = Join(ScriptForge.SF_String.SplitNotQuoted(psSql, "[", , sConstQuote), sQuote) + sSql = Join(ScriptForge.SF_String.SplitNotQuoted(sSql, "]", , sConstQuote), sQuote) + +Finally: + _ReplaceSquareBrackets = sSql + Exit Function +End Function ' SFDatabases.SF_Database._ReplaceSquareBrackets + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Database instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DATABASE]: Location (Statusbar)" + + _Repr = "[DATABASE]: " & _Location & " (" & _URL & ")" + +End Function ' SFDatabases.SF_Database._Repr + +REM ============================================ END OF SFDATABASES.SF_DATABASE + \ No newline at end of file diff --git a/wizards/source/sfdatabases/SF_Register.xba b/wizards/source/sfdatabases/SF_Register.xba new file mode 100644 index 000000000..c9b3f03d7 --- /dev/null +++ b/wizards/source/sfdatabases/SF_Register.xba @@ -0,0 +1,195 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDatabases library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR" + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Database", "SFDatabases.SF_Register._NewDatabase") ' Reference to the function initializing the service + .RegisterService("DatabaseFromDocument", "SFDatabases.SF_Register._NewDatabaseFromSource") + End With + +End Sub ' SFDatabases.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _NewDatabase(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_Database class +' Args: +''' FileName : the name of the file (compliant with the SF_FileSystem.FileNaming notation) +''' RegistrationName: mutually exclusive with FileName. Used when database is registered +''' ReadOnly : (boolean). Default = True +''' User : connection parameters +''' Password +''' Returns: +''' The instance or Nothing +''' Exceptions: +''' BASEDOCUMENTOPENERROR The database file could not be opened or connected + +Dim oDatabase As Object ' Return value +Dim vFileName As Variant ' alias of pvArgs(0) +Dim vRegistration As Variant ' Alias of pvArgs(1) +Dim vReadOnly As Variant ' Alias of pvArgs(2) +Dim vUser As Variant ' Alias of pvArgs(3) +Dim vPassword As Variant ' Alias of pvArgs(4) +Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext +Const cstService = "SFDatabases.Database" +Const cstGlobal = "GlobalScope" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vFileName = pvArgs(0) Else vFileName = "" + If IsEmpty(vFileName) Then vFileName = "" + If UBound(pvArgs) >= 1 Then vRegistration = pvArgs(1) Else vRegistration = "" + If IsEmpty(vRegistration) Then vRegistration = "" + If UBound(pvArgs) >= 2 Then vReadOnly = pvArgs(2) Else vReadOnly = True + If IsEmpty(vReadOnly) Then vReadOnly = True + If UBound(pvArgs) >= 3 Then vUser = pvArgs(3) Else vUser = "" + If IsEmpty(vUser) Then vUser = "" + If UBound(pvArgs) >= 4 Then vPassword = pvArgs(4) Else vPassword = "" + If IsEmpty(vPassword) Then vPassword = "" + If Not ScriptForge.SF_Utils._Validate(vFileName, "FileName", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vRegistration, "RegistrationName", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vReadOnly, "ReadOnly", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vUser, "User", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vPassword, "Password", V_STRING) Then GoTo Finally + Set oDatabase = Nothing + + ' Check the existence of FileName + With ScriptForge + Set oDBContext = .SF_Utils._GetUNOService("DatabaseContext") + If Len(vFileName) = 0 Then ' FileName has precedence over RegistrationName + If Len(vRegistration) = 0 Then GoTo CatchError + If Not oDBContext.hasRegisteredDatabase(vRegistration) Then GoTo CatchError + vFileName = .SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(vRegistration)) + End If + If Not .SF_FileSystem.FileExists(vFileName) Then GoTo CatchError + End With + +Try: + ' Create the database Basic object and initialize attributes + Set oDatabase = New SF_Database + With oDatabase + Set .[Me] = oDatabase + ._Location = ConvertToUrl(vFileName) + Set ._DataSource = oDBContext.getByName(._Location) + Set ._Connection = ._DataSource.getConnection(vUser, vPassword) + ._ReadOnly = vReadOnly + Set ._MetaData = ._Connection.MetaData + ._URL = ._MetaData.URL + End With + +Finally: + Set _NewDatabase = oDatabase + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", vFileName, "RegistrationName", vRegistration) + GoTo Finally +End Function ' SFDatabases.SF_Register._NewDatabase + +REM ----------------------------------------------------------------------------- +Public Function _NewDatabaseFromSource(Optional ByVal pvArgs As Variant) As Object +' ByRef poDataSource As Object _ +' , ByVal psUser As String _ +' , ByVal psPassword As String _ +' ) As Object +''' Create a new instance of the SF_Database class from the given datasource +''' established in the SFDocuments.Base service +''' THIS SERVICE MUST NOT BE CALLED FROM A USER SCRIPT +' Args: +''' DataSource: com.sun.star.sdbc.XDataSource +''' User, Password : connection parameters +''' Returns: +''' The instance or Nothing +''' Exceptions: +''' managed in the calling routines when Nothing is returned + +Dim oDatabase As Object ' Return value +Dim oConnection As Object ' com.sun.star.sdbc.XConnection +Dim oDataSource As Object ' Alias of pvArgs(0) +Dim sUser As String ' Alias of pvARgs(1) +Dim sPassword As String ' Alias of pvARgs(2) + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oDatabase = Nothing + +Try: + ' Get arguments + Set oDataSource = pvArgs(0) + sUser = pvArgs(1) + sPassword = pvArgs(2) + + ' Setup the connection + If oDataSource.IsPasswordRequired Then + Set oConnection = oDataSource.getConnection(sUser, sPassword) + Else + Set oConnection = oDataSource.getConnection("", "") + End If + + ' Create the database Basic object and initialize attributes + If Not IsNull(oConnection) Then + Set oDatabase = New SF_Database + With oDatabase + Set .[Me] = oDatabase + ._Location = "" + Set ._DataSource = oDataSource + Set ._Connection = oConnection + ._ReadOnly = oConnection.isReadOnly() + Set ._MetaData = oConnection.MetaData + ._URL = ._MetaData.URL + End With + End If + +Finally: + Set _NewDatabaseFromSource = oDatabase + Exit Function +Catch: + GoTo Finally +End Function ' SFDatabases.SF_Register._NewDatabaseFromSource + +REM ============================================== END OF SFDATABASES.SF_REGISTER + \ No newline at end of file diff --git a/wizards/source/sfdatabases/__License.xba b/wizards/source/sfdatabases/__License.xba new file mode 100644 index 000000000..3b0c64d04 --- /dev/null +++ b/wizards/source/sfdatabases/__License.xba @@ -0,0 +1,26 @@ + + + +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDatabases library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/sfdatabases/dialog.xlb b/wizards/source/sfdatabases/dialog.xlb new file mode 100644 index 000000000..8b62d721a --- /dev/null +++ b/wizards/source/sfdatabases/dialog.xlb @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/wizards/source/sfdatabases/script.xlb b/wizards/source/sfdatabases/script.xlb new file mode 100644 index 000000000..6cea80d2a --- /dev/null +++ b/wizards/source/sfdatabases/script.xlb @@ -0,0 +1,7 @@ + + + + + + + \ No newline at end of file diff --git a/wizards/source/sfdialogs/SF_Dialog.xba b/wizards/source/sfdialogs/SF_Dialog.xba new file mode 100644 index 000000000..da2afcb4a --- /dev/null +++ b/wizards/source/sfdialogs/SF_Dialog.xba @@ -0,0 +1,1111 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDialogs library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Dialog +''' ========= +''' Management of dialogs defined with the Basic IDE +''' Each instance of the current class represents a single dialog box displayed to the user +''' +''' A dialog box can be displayed in modal or in non-modal modes +''' In modal mode, the box is displayed and the execution of the macro process is suspended +''' until one of the OK or Cancel buttons is pressed. In the meantime, other user actions +''' executed on the box can trigger specific actions. +''' In non-modal mode, the dialog box is "floating" on the user desktop and the execution +''' of the macro process continues normally +''' A dialog box disappears from memory after its explicit termination. +''' +''' Service invocation and usage: +''' Dim myDialog As Object, lButton As Long +''' Set myDialog = CreateScriptService("SFDialogs.Dialog", Container, Library, DialogName) +''' ' Args: +''' ' Container: "GlobalScope" for preinstalled libraries +''' ' A window name (see its definition in the ScriptForge.UI service) +''' ' "" (default) = the current document +''' ' Library: The (case-sensitive) name of a library contained in the container +''' ' Default = "Standard" +''' ' DialogName: a case-sensitive string designating the dialog where it is about +''' ' ... Initialize controls ... +''' lButton = myDialog.Execute() ' Default mode = Modal +''' If lButton = myDialog.OKBUTTON Then +''' ' ... Process controls and do what is needed +''' End If +''' myDialog.Terminate() +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_dialog.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DIALOGDEADERROR = "DIALOGDEADERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be DIALOG +Private ServiceName As String + +' Dialog location +Private _Container As String +Private _Library As String +Private _Name As String +Private _CacheIndex As Long ' Index in cache storage + +' Dialog UNO references +Private _DialogProvider As Object ' com.sun.star.io.XInputStreamProvider +Private _DialogControl As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Private _DialogModel As Object ' com.sun.star.awt.XControlModel - stardiv.Toolkit.UnoControlDialogModel + +' Dialog attributes +Private _Displayed As Boolean ' True after Execute() +Private _Modal As Boolean ' Set by Execute() + +' Dialog position and dimensions +Private _Left As Long +Private _Top As Long +Private _Width As Long +Private _Height As Long + +' Persistent storage for controls +Private _ControlCache As Variant ' Array of control objects sorted like ElementNames of the Dialog model + +REM ============================================================ MODULE CONSTANTS + +Private Const OKBUTTON = 1 +Private Const CANCELBUTTON = 0 + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DIALOG" + ServiceName = "SFDialogs.Dialog" + _Container = "" + _Library = "" + _Name = "" + _CacheIndex = -1 + Set _DialogProvider = Nothing + Set _DialogControl = Nothing + Set _DialogModel = Nothing + _Displayed = False + _Modal = True + _Left = -1 + _Top = -1 + _Width = -1 + _Height = -1 + _ControlCache = Array() +End Sub ' SFDialogs.SF_Dialog Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDialogs.SF_Dialog Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If _CacheIndex >= 0 Then Terminate() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDialogs.SF_Dialog Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Caption() As Variant +''' The Caption property refers to the title of the dialog + Caption = _PropertyGet("Caption") +End Property ' SFDialogs.SF_Dialog.Caption (get) + +REM ----------------------------------------------------------------------------- +Property Let Caption(Optional ByVal pvCaption As Variant) +''' Set the updatable property Caption + _PropertySet("Caption", pvCaption) +End Property ' SFDialogs.SF_Dialog.Caption (let) + +REM ----------------------------------------------------------------------------- +Property Get Height() As Variant +''' The Height property refers to the height of the dialog box + Height = _PropertyGet("Height") +End Property ' SFDialogs.SF_Dialog.Height (get) + +REM ----------------------------------------------------------------------------- +Property Let Height(Optional ByVal pvHeight As Variant) +''' Set the updatable property Height + _PropertySet("Height", pvHeight) +End Property ' SFDialogs.SF_Dialog.Height (let) + +REM ----------------------------------------------------------------------------- +Property Get Modal() As Boolean +''' The Modal property specifies if the dialog box has been executed in modal mode + Modal = _PropertyGet("Modal") +End Property ' SFDialogs.SF_Dialog.Modal (get) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual dialog + Name = _PropertyGet("Name") +End Property ' SFDialogs.SF_Dialog.Name + +REM ----------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant +''' Get the script associated with the OnFocusGained event + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' SFDialogs.SF_Dialog.OnFocusGained (get) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant +''' Get the script associated with the OnFocusLost event + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' SFDialogs.SF_Dialog.OnFocusLost (get) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant +''' Get the script associated with the OnKeyPressed event + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' SFDialogs.SF_Dialog.OnKeyPressed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant +''' Get the script associated with the OnKeyReleased event + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' SFDialogs.SF_Dialog.OnKeyReleased (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant +''' Get the script associated with the OnMouseDragged event + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' SFDialogs.SF_Dialog.OnMouseDragged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant +''' Get the script associated with the OnMouseEntered event + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' SFDialogs.SF_Dialog.OnMouseEntered (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant +''' Get the script associated with the OnMouseExited event + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' SFDialogs.SF_Dialog.OnMouseExited (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant +''' Get the script associated with the OnMouseMoved event + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' SFDialogs.SF_Dialog.OnMouseMoved (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant +''' Get the script associated with the OnMousePressed event + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' SFDialogs.SF_Dialog.OnMousePressed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant +''' Get the script associated with the OnMouseReleased event + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' SFDialogs.SF_Dialog.OnMouseReleased (get) + +REM ----------------------------------------------------------------------------- +Property Get Page() As Variant +''' A dialog may have several pages that can be traversed by the user step by step. The Page property of the Dialog object defines which page of the dialog is active. +''' The Page property of a control defines the page of the dialog on which the control is visible. +''' For example, if a control has a page value of 1, it is only visible on page 1 of the dialog. +''' If the page value of the dialog is increased from 1 to 2, then all controls with a page value of 1 disappear and all controls with a page value of 2 become visible. + Page = _PropertyGet("Page") +End Property ' SFDialogs.SF_Dialog.Page (get) + +REM ----------------------------------------------------------------------------- +Property Let Page(Optional ByVal pvPage As Variant) +''' Set the updatable property Page + _PropertySet("Page", pvPage) +End Property ' SFDialogs.SF_Dialog.Page (let) + +REM ----------------------------------------------------------------------------- +Property Get Visible() As Variant +''' The Visible property is False before the Execute() statement + Visible = _PropertyGet("Visible") +End Property ' SFDialogs.SF_Dialog.Visible (get) + +REM ----------------------------------------------------------------------------- +Property Let Visible(Optional ByVal pvVisible As Variant) +''' Set the updatable property Visible + _PropertySet("Visible", pvVisible) +End Property ' SFDialogs.SF_Dialog.Visible (let) + +REM ----------------------------------------------------------------------------- +Property Get Width() As Variant +''' The Width property refers to the Width of the dialog box + Width = _PropertyGet("Width") +End Property ' SFDialogs.SF_Dialog.Width (get) + +REM ----------------------------------------------------------------------------- +Property Let Width(Optional ByVal pvWidth As Variant) +''' Set the updatable property Width + _PropertySet("Width", pvWidth) +End Property ' SFDialogs.SF_Dialog.Width (let) + +REM ----------------------------------------------------------------------------- +Property Get XDialogModel() As Object +''' The XDialogModel property returns the model UNO object of the dialog + XDialogModel = _PropertyGet("XDialogModel") +End Property ' SFDialogs.SF_Dialog.XDialogModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XDialogView() As Object +''' The XDialogView property returns the view UNO object of the dialog + XDialogView = _PropertyGet("XDialogView") +End Property ' SFDialogs.SF_Dialog.XDialogView (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean +''' Set the focus on the current dialog instance +''' Probably called from after an event occurrence or to focus on a non-modal dialog +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' Dim oDlg As Object +''' Set oDlg = CreateScriptService(,, "myDialog") ' Dialog stored in current document's standard library +''' oDlg.Activate() + +Dim bActivate As Boolean ' Return value +Const cstThisSub = "SFDialogs.Dialog.Activate" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActivate = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + If Not IsNull(_DialogControl) Then + _DialogControl.setFocus() + bActivate = True + End If + +Finally: + Activate = bActivate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog.Activate + +REM ----------------------------------------------------------------------------- +Public Function Center(Optional ByRef Parent As Variant) As Boolean +''' Center the actual dialog instance in the middle of a parent window +''' Without arguments, the method centers the dialog in the middle of the current window +''' Args: +''' Parent: an object, either +''' - a ScriptForge dialog object +''' - a ScriptForge document (Calc, Base, ...) object +''' Returns: +''' True when successful +''' Examples: +''' Sub TriggerEvent(oEvent As Object) +''' Dim oDialog1 As Object, oDialog2 As Object, lExec As Long +''' Set oDialog1 = CreateScriptService("DialogEvent", oEvent) ' The dialog having caused the event +''' Set oDialog2 = CreateScriptService("Dialog", ...) ' Open a second dialog +''' oDialog2.Center(oDialog1) +''' lExec = oDialog2.Execute() +''' Select Case lExec +''' ... +''' End Sub + +Dim bCenter As Boolean ' Return value +Dim oUi As Object ' ScriptForge.SF_UI +Dim oObjDesc As Object ' _ObjectDescriptor type +Dim sObjectType As String ' Can be uno or sf object type +Dim oParent As Object ' UNO alias of parent +Dim oParentPosSize As Object ' Parent com.sun.star.awt.Rectangle +Dim lParentX As Long ' X position of parent dialog +Dim lParentY As Long ' Y position of parent dialog +Dim oPosSize As Object ' Dialog com.sun.star.awt.Rectangle +Const cstThisSub = "SFDialogs.Dialog.Center" +Const cstSubArgs = "[Parent]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCenter = False + +Check: + If IsMissing(Parent) Or IsEmpty(Parent) Then Set Parent = Nothing + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(Parent, "Parent", ScriptForge.V_OBJECT) Then GoTo Finally + End If + + Set oParentPosSize = Nothing + lParentX = 0 : lParentY = 0 + If IsNull(Parent) Then + Set oUi = CreateScriptService("UI") + Set oParentPosSize = oUi._PosSize() ' Return the position and dimensions of the active window + Else + ' Determine the object type + Set oObjDesc = ScriptForge.SF_Utils._VarTypeObj(Parent) + If oObjDesc.iVarType = ScriptForge.V_SFOBJECT Then ' ScriptForge object + sObjectType = oObjDesc.sObjectType + ' Document or dialog ? + If Not ScriptForge.SF_Array.Contains(Array("BASE", "CALC", "DIALOG", "DOCUMENT", "WRITER"), sObjectType, CaseSensitive := True) Then GoTo Finally + If sObjectType = "DIALOG" Then + Set oParent = Parent._DialogControl + Set oParentPosSize = oParent.getPosSize() + lParentX = oParentPosSize.X + lParentY = oParentPosSize.Y + Else + Set oParent = Parent._Component.getCurrentController().Frame.getComponentWindow() + Set oParentPosSize = oParent.getPosSize() + End If + Else + GoTo Finally ' UNO object, do nothing + End If + End If + If IsNull(oParentPosSize) Then GoTo Finally + +Try: + Set oPosSize = _DialogControl.getPosSize() + With oPosSize + _DialogControl.setPosSize( _ + lParentX + CLng((oParentPosSize.Width - .Width) \ 2) _ + , lParentY + CLng((oParentPosSize.Height - .Height) \ 2) _ + , .Width _ + , .Height _ + , com.sun.star.awt.PosSize.POSSIZE) + End With + bCenter = True + +Finally: + Center = bCenter + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Dialog.Center + +REM ----------------------------------------------------------------------------- +Public Function Controls(Optional ByVal ControlName As Variant) As Variant +''' Return either +''' - the list of the controls contained in the dialog +''' - a dialog control object based on its name +''' Args: +''' ControlName: a valid control name as a case-sensitive string. If absent the list is returned +''' Returns: +''' A zero-base array of strings if ControlName is absent +''' An instance of the SF_DialogControl class if ControlName exists +''' Exceptions: +''' ControlName is invalid +''' Example: +''' Dim myDialog As Object, myList As Variant, myControl As Object +''' Set myDialog = CreateScriptService("SFDialogs.Dialog", Container, Library, DialogName) +''' myList = myDialog.Controls() +''' Set myControl = myDialog.Controls("myTextBox") + +Dim oControl As Object ' The new control class instance +Dim lIndexOfNames As Long ' Index in ElementNames array. Used to access _ControlCache +Dim vControl As Variant ' Alias of _ControlCache entry +Const cstThisSub = "SFDialogs.Dialog.Controls" +Const cstSubArgs = "[ControlName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(ControlName) Or IsEmpty(ControlName) Then ControlName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING) Then GoTo Finally + End If + +Try: + If Len(ControlName) = 0 Then + Controls = _DialogModel.getElementNames() + Else + If Not _DialogModel.hasByName(ControlName) Then GoTo CatchNotFound + lIndexOfNames = ScriptForge.IndexOf(_DialogModel.getElementNames(), ControlName, CaseSensitive := True) + ' Reuse cache when relevant + vControl = _ControlCache(lIndexOfNames) + If IsEmpty(vControl) Then + ' Create the new dialog control class instance + Set oControl = New SF_DialogControl + With oControl + ._Name = ControlName + Set .[Me] = oControl + Set .[_Parent] = [Me] + ._IndexOfNames = ScriptForge.IndexOf(_DialogModel.getElementNames(), ControlName, CaseSensitive := True) + ._DialogName = _Name + Set ._ControlModel = _DialogModel.getByName(ControlName) + Set ._ControlView = _DialogControl.getControl(ControlName) + ._Initialize() + End With + Else + Set oControl = vControl + End If + Set Controls = oControl + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING, _DialogModel.getElementNames()) + GoTo Finally +End Function ' SFDialogs.SF_Dialog.Controls + +REM ----------------------------------------------------------------------------- +Public Sub EndExecute(Optional ByVal ReturnValue As Variant) +''' Ends the display of a modal dialog and gives back the argument +''' as return value for the current Execute() action +''' EndExecute is usually contained in the processing of a macro +''' triggered by a dialog or control event +''' Args: +''' ReturnValue: must be numeric. The value passed to the running Execute() method +''' Example: +''' Sub OnEvent(poEvent As Variant) +''' Dim oDlg As Object +''' Set oDlg = CreateScriptService("SFDialogs.DialogEvent", poEvent) +''' oDlg.EndExecute(25) +''' End Sub + +Dim lExecute As Long ' Alias of ReturnValue +Const cstThisSub = "SFDialogs.Dialog.EndExecute" +Const cstSubArgs = "ReturnValue" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ReturnValue, "ReturnValue", V_NUMERIC) Then GoTo Finally + End If + +Try: + lExecute = CLng(ReturnValue) + Call _DialogControl.endDialog(lExecute) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SFDialogs.SF_Dialog.EndExecute + +REM ----------------------------------------------------------------------------- +Public Function Execute(Optional ByVal Modal As Variant) As Long +''' Display the dialog and wait for its termination by the user +''' Args: +''' Modal: False when non-modal dialog. Default = True +''' Returns: +''' 0 = Cancel button pressed +''' 1 = OK button pressed +''' Otherwise: the dialog stopped with an EndExecute statement executed from a dialog or control event +''' Example: +''' Dim oDlg As Object, lReturn As Long +''' Set oDlg = CreateScriptService(,, "myDialog") ' Dialog stored in current document's standard library +''' lReturn = oDlg.Execute() +''' Select Case lReturn + +Dim lExecute As Long ' Return value +Const cstThisSub = "SFDialogs.Dialog.Execute" +Const cstSubArgs = "[Modal=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + lExecute = -1 + +Check: + If IsMissing(Modal) Or IsEmpty(Modal) Then Modal = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Modal, "Modal", V_BOOLEAN) Then GoTo Finally + End If + +Try: + If Modal Then + _Modal = True + _Displayed = True + lExecute = _DialogControl.execute() + Select Case lExecute + Case 1 : lExecute = OKBUTTON + Case 0 : lExecute = CANCELBUTTON + Case Else + End Select + _Displayed = False + Else + _Modal = False + _Displayed = True + _DialogModel.DesktopAsParent = True + _DialogControl.setVisible(True) + lExecute = 0 + End If + +Finally: + Execute = lExecute + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog.Execute + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' oDlg.GetProperty("Caption") + +Const cstThisSub = "SFDialogs.Dialog.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetTextsFromL10N(Optional ByRef L10N As Variant) As Boolean +''' Replace all fixed text strings of a dialog by their localized version +''' Replaced texts are: +''' - the title of the dialog +''' - the caption associated with next control types: Button, CheckBox, FixedLine, FixedText, GroupBox and RadioButton +''' - the content of list- and comboboxes +''' - the tip- or helptext displayed when the mouse is hovering the control +''' The current method has a twin method ScriptForge.SF_L10N.AddTextsFromDialog +''' The current method is probably run before the Execute() method +''' Args: +''' L10N : a "L10N" service instance created with CreateScriptService("L10N") +''' Returns: +''' True when successful +''' Examples: +''' Dim myPO As Object, oDlg As Object +''' Set oDlg = CreateScriptService("Dialog", "GlobalScope", "XrayTool", "DlgXray") +''' Set myPO = CreateScriptService("L10N", "C:\myPOFiles\", "fr-BE") +''' oDlg.GetTextsFromL10N(myPO) + +Dim bGet As Boolean ' Return value +Dim vControls As Variant ' Array of control names +Dim sControl As String ' A single control name +Dim oControl As Object ' SFDialogs.DialogControl +Dim sText As String ' The text found in the dialog +Dim sTranslation As String ' The translated text got from the dictionary +Dim vSource As Variant ' RowSource property of dialog control as an array +Dim bChanged As Boolean ' True when at least 1 item of a RowSource is modified +Dim i As Long + +Const cstThisSub = "SFDialogs.Dialog.GetTextsFromL10N" +Const cstSubArgs = "L10N" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bGet = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(L10N, "L10N", V_OBJECT, , , "L10N") Then GoTo Finally + End If + +Try: + ' Get the dialog title + sText = Caption + If Len(sText) > 0 Then + sTranslation = L10N._(sText) + If sText <> sTranslation Then Caption = sTranslation + End If + ' Scan all controls + vControls = Controls() + For Each sControl In vControls + Set oControl = Controls(sControl) + With oControl + ' Extract fixed texts + sText = .Caption + If Len(sText) > 0 Then + sTranslation = L10N._(sText) + If sText <> sTranslation Then .Caption = sTranslation + End If + vSource = .RowSource ' List and comboboxes only + If IsArray(vSource) Then + bChanged = False + For i = 0 To UBound(vSource) + If Len(vSource(i)) > 0 Then + sTranslation = L10N._(vSource(i)) + If sTranslation <> vSource(i) Then + bChanged = True + vSource(i) = sTranslation + End If + End If + Next i + ' Rewrite if at least 1 item has been modified by the translation process + If bChanged Then .RowSource = vSource + End If + sText = .TipText + If Len(sText) > 0 Then + sTranslation = L10N._(sText) + If sText <> sTranslation Then .TipText = sTranslation + End If + End With + Next sControl + + bGet = True + +Finally: + GetTextsFromL10N = bGet + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog.GetTextsFromL10N + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "Activate" _ + , "Center" _ + , "Controls" _ + , "EndExecute" _ + , "Execute" _ + , "GetTextsFromL10N" _ + , "Resize" _ + , "Terminate" _ + ) + +End Function ' SFDialogs.SF_Dialog.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Dialog class as an array + + Properties = Array( _ + "Caption" _ + , "Height" _ + , "Modal" _ + , "Name" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "Page" _ + , "Visible" _ + , "Width" _ + , "XDialogModel" _ + , "XDialogView" _ + ) + +End Function ' SFDialogs.SF_Dialog.Properties + +REM ----------------------------------------------------------------------------- +Public Function Resize(Optional ByVal Left As Variant _ + , Optional ByVal Top As Variant _ + , Optional ByVal Width As Variant _ + , Optional ByVal Height As Variant _ + ) As Boolean +''' Move the top-left corner of a dialog to new coordinates and/or modify its dimensions +''' All distances are expressed in 1/100 mm. +''' Without arguments, the method resets the initial dimensions +''' Args: +''' Left : the horizontal distance from the top-left corner +''' Top : the vertical distance from the top-left corner +''' Width : the horizontal width of the rectangle containing the Dialog +''' Height : the vertical height of the rectangle containing the Dialog +''' Negative or missing arguments are left unchanged +''' Returns: +''' True when successful +''' Examples: +''' oDialog.Resize(1000, 2000, Height := 6000) ' Width is not changed + +Dim bResize As Boolean ' Return value +Dim oPosSize As Object ' com.sun.star.awt.Rectangle +Dim iFlags As Integer ' com.sun.star.awt.PosSize constants +Const cstThisSub = "SFDialogs.Dialog.Resize" +Const cstSubArgs = "[Left], [Top], [Width], [Height]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bResize = False + +Check: + If IsMissing(Left) Or IsEmpty(Left) Then Left = -1 + If IsMissing(Top) Or IsEmpty(Top) Then Top = -1 + If IsMissing(Height) Or IsEmpty(Height) Then Height = -1 + If IsMissing(Width) Or IsEmpty(Width) Then Width = -1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(Left, "Left", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Top, "Top", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + With _DialogControl + Set oPosSize = .getPosSize() + ' Reset factory settings + If Left = -1 And Top = -1 And Width = -1 And Height = -1 Then + 'Left = _Left ' Initial positions determination is unstable + 'Top = _Top + Width = _Width + Height = _Height + End If + ' Trace the elements to change + iFlags = 0 + With com.sun.star.awt.PosSize + If Left >= 0 Then iFlags = iFlags + .X Else Left = oPosSize.X + If Top >= 0 Then iFlags = iFlags + .Y Else Top = oPosSize.Y + If Width > 0 Then iFlags = iFlags + .WIDTH Else Width = oPosSize.Width + If Height > 0 Then iFlags = iFlags + .HEIGHT Else Height = oPosSize.Height + End With + ' Rewrite + If iFlags > 0 Then .setPosSize(CLng(Left), CLng(Top), CLng(Width), CLng(Height), iFlags) + End With + bResize = True + +Finally: + Resize = bResize + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Dialog.Resize + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDialogs.Dialog.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Terminate() As Boolean +''' Terminate the dialog service for the current dialog instance +''' After termination any action on the current instance will be ignored +''' Args: +''' Returns: +''' True if termination is successful +''' Example: +''' Dim oDlg As Object, lReturn As Long +''' Set oDlg = CreateScriptService(,, "myDialog") ' Dialog stored in current document's standard library +''' lreturn = oDlg.Execute() +''' Select Case lReturn +''' ' ... +''' End Select +''' oDlg.Terminate() + +Dim bTerminate As Boolean ' Return value +Const cstThisSub = "SFDialogs.Dialog.Terminate" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bTerminate = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + _DialogControl.dispose() + Set _DialogControl = Nothing + SF_Register._CleanCacheEntry(_CacheIndex) + _CacheIndex = -1 + Dispose() + + bTerminate = True + +Finally: + Terminate = bTerminate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog.Terminate + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDialogs.SF_Dialog._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case Else + _GetListener = "" + End Select + +End Function ' SFDialogs.SF_Dialog._GetListener + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Complete the object creation process: +''' - Initialization of private members +''' - Creation of the dialog graphical interface +''' - Addition of the new object in the Dialogs buffer +''' - Initialisation of persistent storage for controls + +Dim oPosSize As Object ' com.sun.star.awt.Rectangle + +Try: + ' Keep reference to model + Set _DialogModel = _DialogControl.Model + + ' Store initial position and dimensions + Set oPosSize = _DialogControl.getPosSize() + With oPosSize + _Left = .X + _Top = .Y + _Width = .Width + _Height = .Height + End With + + ' Add dialog reference to cache + _CacheIndex = SF_Register._AddDialogToCache(_DialogControl, [Me]) + + ' Size the persistent storage + _ControlCache = Array() + ReDim _ControlCache(0 To UBound(_DialogModel.getElementNames())) + +Finally: + Exit Sub +End Sub ' SFDialogs.SF_Dialog._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbError As Boolean) As Boolean +''' Return True if the dialog service is still active +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value +Dim sDialog As String ' Alias of DialogName + +Check: + On Local Error GoTo Catch ' Anticipate DisposedException errors or alike + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = ( Not IsNull(_DialogProvider) And Not IsNull(_DialogControl) ) + If Not bAlive Then GoTo Catch + +Finally: + _IsStillAlive = bAlive + Exit Function +Catch: + bAlive = False + On Error GoTo 0 + sDialog = _Name + Dispose() + If pbError Then ScriptForge.SF_Exception.RaiseFatal(DIALOGDEADERROR, sDialog) + GoTo Finally +End Function ' SFDialogs.SF_Dialog._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Static oSession As Object ' Alias of SF_Session +Dim oDialogEvents As Object ' com.sun.star.container.XNameContainer +Dim sEventName As String ' Internal event name +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDialogs.Dialog.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("Caption") + If oSession.HasUNOProperty(_DialogModel, "Title") Then _PropertyGet = _DialogModel.Title + Case UCase("Height") + If oSession.HasUNOProperty(_DialogModel, "Height") Then _PropertyGet = _DialogModel.Height + Case UCase("Modal") + _PropertyGet = _Modal + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased") + Set oDialogEvents = _DialogModel.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & _GetEventName(psProperty) + If oDialogEvents.hasByName(sEventName) Then + _PropertyGet = oDialogEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case UCase("Page") + If oSession.HasUNOProperty(_DialogModel, "Step") Then _PropertyGet = _DialogModel.Step + Case UCase("Visible") + If oSession.HasUnoMethod(_DialogControl, "isVisible") Then _PropertyGet = CBool(_DialogControl.isVisible()) + Case UCase("Width") + If oSession.HasUNOProperty(_DialogModel, "Width") Then _PropertyGet = _DialogModel.Width + Case UCase("XDialogModel") + Set _PropertyGet = _DialogModel + Case UCase("XDialogView") + Set _PropertyGet = _DialogControl + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDialogs.Dialog.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("Caption") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Caption", V_STRING) Then GoTo Finally + If oSession.HasUNOProperty(_DialogModel, "Title") Then _DialogModel.Title = pvValue + Case UCase("Height") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUNOProperty(_DialogModel, "Height") Then _DialogModel.Height = pvValue + Case UCase("Page") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Page", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUNOProperty(_DialogModel, "Step") Then _DialogModel.Step = CLng(pvValue) + Case UCase("Visible") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Visible", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoMethod(_DialogControl, "setVisible") Then _DialogControl.setVisible(pvValue) + Case UCase("Width") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUNOProperty(_DialogModel, "Width") Then _DialogModel.Width = pvValue + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_Dialog._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DIALOG]: Container.Library.Name" + + _Repr = "[DIALOG]: " & _Container & "." & _Library & "." & _Name + +End Function ' SFDialogs.SF_Dialog._Repr + +REM ============================================ END OF SFDIALOGS.SF_DIALOG + \ No newline at end of file diff --git a/wizards/source/sfdialogs/SF_DialogControl.xba b/wizards/source/sfdialogs/SF_DialogControl.xba new file mode 100644 index 000000000..f4a0891d9 --- /dev/null +++ b/wizards/source/sfdialogs/SF_DialogControl.xba @@ -0,0 +1,2084 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDialogs library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_DialogControl +''' ================ +''' Manage the controls belonging to a dialog defined with the Basic IDE +''' Each instance of the current class represents a single control within a dialog box +''' +''' The focus is clearly set on getting and setting the values displayed by the controls of the dialog box, +''' not on their formatting. The latter is easily accessible via the XControlModel and XControlView +''' UNO objects. +''' Essentially a single property "Value" maps many alternative UNO properties depending each on +''' the control type. +''' +''' A special attention is given to controls with types TreeControl and TableControl +''' It is easy with the API proposed in the current class to populate a tree, either +''' - branch by branch (CreateRoot and AddSubNode), or +''' - with a set of branches at once (AddSubtree) +''' Additionally populating a TreeControl can be done statically or dynamically +''' +''' With the method SetTableData(), feed a tablecontrol with a sortable and selectable +''' array of data. Columns and rows may receive a header. Column widths are adjusted manually by the user or +''' with the same method. Alignments can be set as well by script. +''' +''' Service invocation: +''' Dim myDialog As Object, myControl As Object +''' Set myDialog = CreateScriptService("SFDialogs.Dialog", "GlobalScope", myLibrary, DialogName) +''' Set myControl = myDialog.Controls("myTextBox") +''' myControl.Value = "Dialog started at " & Now() +''' myDialog.Execute() +''' ' ... process the controls actual values +''' myDialog.Terminate() +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_dialogcontrol.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const CONTROLTYPEERROR = "CONTROLTYPEERROR" +Private Const TEXTFIELDERROR = "TEXTFIELDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be DIALOGCONTROL +Private ServiceName As String + +' Control naming +Private _Name As String +Private _IndexOfNames As Long ' Index in ElementNames array. Used to access SF_Dialog._ControlCache +Private _DialogName As String ' Parent dialog name + +' Control UNO references +Private _ControlModel As Object ' com.sun.star.awt.XControlModel +Private _ControlView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Private _TreeDataModel As Object ' com.sun.star.awt.tree.MutableTreeDataModel +Private _GridColumnModel As Object ' com.sun.star.awt.grid.XGridColumnModel +Private _GridDataModel As Object ' com.sun.star.awt.grid.XGridDataModel + +' Control attributes +Private _ImplementationName As String +Private _ControlType As String ' One of the CTLxxx constants + +' Tree control on-select and on-expand attributes +' Tree controls may be associated with events not defined in the Basic IDE +Private _OnNodeSelected As String ' Script to invoke when a node is selected +Private _OnNodeExpanded As String ' Script to invoke when a node is expanded +Private _SelectListener As Object ' com.sun.star.view.XSelectionChangeListener +Private _ExpandListener As Object ' com.sun.star.awt.tree.XTreeExpansionListener + +' Table control attributes +Private _ColumnWidths As Variant ' Array of column widths + +REM ============================================================ MODULE CONSTANTS + +Private Const CTLBUTTON = "Button" +Private Const CTLCHECKBOX = "CheckBox" +Private Const CTLCOMBOBOX = "ComboBox" +Private Const CTLCURRENCYFIELD = "CurrencyField" +Private Const CTLDATEFIELD = "DateField" +Private Const CTLFILECONTROL = "FileControl" +Private Const CTLFIXEDLINE = "FixedLine" +Private Const CTLFIXEDTEXT = "FixedText" +Private Const CTLFORMATTEDFIELD = "FormattedField" +Private Const CTLGROUPBOX = "GroupBox" +Private Const CTLIMAGECONTROL = "ImageControl" +Private Const CTLLISTBOX = "ListBox" +Private Const CTLNUMERICFIELD = "NumericField" +Private Const CTLPATTERNFIELD = "PatternField" +Private Const CTLPROGRESSBAR = "ProgressBar" +Private Const CTLRADIOBUTTON = "RadioButton" +Private Const CTLSCROLLBAR = "ScrollBar" +Private Const CTLTABLECONTROL = "TableControl" +Private Const CTLTEXTFIELD = "TextField" +Private Const CTLTIMEFIELD = "TimeField" +Private Const CTLTREECONTROL = "TreeControl" + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DIALOGCONTROL" + ServiceName = "SFDialogs.DialogControl" + _Name = "" + _IndexOfNames = -1 + _DialogName = "" + Set _ControlModel = Nothing + Set _ControlView = Nothing + Set _TreeDataModel = Nothing + Set _GridColumnModel = Nothing + Set _GridDataModel = Nothing + _ImplementationName = "" + _ControlType = "" + _OnNodeSelected = "" + _OnNodeExpanded = "" + Set _SelectListener = Nothing + Set _ExpandListener = Nothing + _ColumnWidths = Array() +End Sub ' SFDialogs.SF_DialogControl Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDialogs.SF_DialogControl Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDialogs.SF_DialogControl Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Cancel() As Variant +''' The Cancel property specifies if a command button has or not the behaviour of a Cancel button. + Cancel = _PropertyGet("Cancel", False) +End Property ' SFDialogs.SF_DialogControl.Cancel (get) + +REM ----------------------------------------------------------------------------- +Property Let Cancel(Optional ByVal pvCancel As Variant) +''' Set the updatable property Cancel + _PropertySet("Cancel", pvCancel) +End Property ' SFDialogs.SF_DialogControl.Cancel (let) + +REM ----------------------------------------------------------------------------- +Property Get Caption() As Variant +''' The Caption property refers to the text associated with the control + Caption = _PropertyGet("Caption", "") +End Property ' SFDialogs.SF_DialogControl.Caption (get) + +REM ----------------------------------------------------------------------------- +Property Let Caption(Optional ByVal pvCaption As Variant) +''' Set the updatable property Caption + _PropertySet("Caption", pvCaption) +End Property ' SFDialogs.SF_DialogControl.Caption (let) + +REM ----------------------------------------------------------------------------- +Property Get ControlType() As String +''' Return the type of the actual control: "CheckBox", "TextField", "DateField", ... + ControlType = _PropertyGet("ControlType") +End Property ' SFDialogs.SF_DialogControl.ControlType + +REM ----------------------------------------------------------------------------- +Property Get CurrentNode() As Variant +''' The CurrentNode property returns the currently selected node +''' It returns Empty when there is no node selected +''' When there are several selections, it returns the topmost node among the selected ones + CurrentNode = _PropertyGet("CurrentNode", "") +End Property ' SFDialogs.SF_DialogControl.CurrentNode (get) + +REM ----------------------------------------------------------------------------- +Property Let CurrentNode(Optional ByVal pvCurrentNode As Variant) +''' Set a single selection in a tree control + _PropertySet("CurrentNode", pvCurrentNode) +End Property ' SFDialogs.SF_DialogControl.CurrentNode (let) + +REM ----------------------------------------------------------------------------- +Property Get Default() As Variant +''' The Default property specifies whether a command button is the default (OK) button. + Default = _PropertyGet("Default", False) +End Property ' SFDialogs.SF_DialogControl.Default (get) + +REM ----------------------------------------------------------------------------- +Property Let Default(Optional ByVal pvDefault As Variant) +''' Set the updatable property Default + _PropertySet("Default", pvDefault) +End Property ' SFDialogs.SF_DialogControl.Default (let) + +REM ----------------------------------------------------------------------------- +Property Get Enabled() As Variant +''' The Enabled property specifies if the control is accessible with the cursor. + Enabled = _PropertyGet("Enabled") +End Property ' SFDialogs.SF_DialogControl.Enabled (get) + +REM ----------------------------------------------------------------------------- +Property Let Enabled(Optional ByVal pvEnabled As Variant) +''' Set the updatable property Enabled + _PropertySet("Enabled", pvEnabled) +End Property ' SFDialogs.SF_DialogControl.Enabled (let) + +REM ----------------------------------------------------------------------------- +Property Get Format() As Variant +''' The Format property specifies the format in which to display dates and times. + Format = _PropertyGet("Format", "") +End Property ' SFDialogs.SF_DialogControl.Format (get) + +REM ----------------------------------------------------------------------------- +Property Let Format(Optional ByVal pvFormat As Variant) +''' Set the updatable property Format +''' NB: Format is read-only for formatted field controls + _PropertySet("Format", pvFormat) +End Property ' SFDialogs.SF_DialogControl.Format (let) + +REM ----------------------------------------------------------------------------- +Property Get ListCount() As Long +''' The ListCount property specifies the number of rows in a list box or a combo box + ListCount = _PropertyGet("ListCount", 0) +End Property ' SFDialogs.SF_DialogControl.ListCount (get) + +REM ----------------------------------------------------------------------------- +Property Get ListIndex() As Variant +''' The ListIndex property specifies which item is selected in a list box or combo box. +''' In case of multiple selection, the index of the first one is returned or only one is set + ListIndex = _PropertyGet("ListIndex", -1) +End Property ' SFDialogs.SF_DialogControl.ListIndex (get) + +REM ----------------------------------------------------------------------------- +Property Let ListIndex(Optional ByVal pvListIndex As Variant) +''' Set the updatable property ListIndex + _PropertySet("ListIndex", pvListIndex) +End Property ' SFDialogs.SF_DialogControl.ListIndex (let) + +REM ----------------------------------------------------------------------------- +Property Get Locked() As Variant +''' The Locked property specifies if a control is read-only + Locked = _PropertyGet("Locked", False) +End Property ' SFDialogs.SF_DialogControl.Locked (get) + +REM ----------------------------------------------------------------------------- +Property Let Locked(Optional ByVal pvLocked As Variant) +''' Set the updatable property Locked + _PropertySet("Locked", pvLocked) +End Property ' SFDialogs.SF_DialogControl.Locked (let) + +REM ----------------------------------------------------------------------------- +Property Get MultiSelect() As Variant +''' The MultiSelect property specifies whether a user can make multiple selections in a listbox + MultiSelect = _PropertyGet("MultiSelect", False) +End Property ' SFDialogs.SF_DialogControl.MultiSelect (get) + +REM ----------------------------------------------------------------------------- +Property Let MultiSelect(Optional ByVal pvMultiSelect As Variant) +''' Set the updatable property MultiSelect + _PropertySet("MultiSelect", pvMultiSelect) +End Property ' SFDialogs.SF_DialogControl.MultiSelect (let) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual control + Name = _PropertyGet("Name") +End Property ' SFDialogs.SF_DialogControl.Name + +REM ----------------------------------------------------------------------------- +Property Get OnActionPerformed() As Variant +''' Get the script associated with the OnActionPerformed event + OnActionPerformed = _PropertyGet("OnActionPerformed") +End Property ' SFDialogs.SF_DialogControl.OnActionPerformed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnAdjustmentValueChanged() As Variant +''' Get the script associated with the OnAdjustmentValueChanged event + OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged") +End Property ' SFDialogs.SF_DialogControl.OnAdjustmentValueChanged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant +''' Get the script associated with the OnFocusGained event + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' SFDialogs.SF_DialogControl.OnFocusGained (get) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant +''' Get the script associated with the OnFocusLost event + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' SFDialogs.SF_DialogControl.OnFocusLost (get) + +REM ----------------------------------------------------------------------------- +Property Get OnItemStateChanged() As Variant +''' Get the script associated with the OnItemStateChanged event + OnItemStateChanged = _PropertyGet("OnItemStateChanged") +End Property ' SFDialogs.SF_DialogControl.OnItemStateChanged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant +''' Get the script associated with the OnKeyPressed event + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' SFDialogs.SF_DialogControl.OnKeyPressed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant +''' Get the script associated with the OnKeyReleased event + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' SFDialogs.SF_DialogControl.OnKeyReleased (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant +''' Get the script associated with the OnMouseDragged event + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' SFDialogs.SF_DialogControl.OnMouseDragged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant +''' Get the script associated with the OnMouseEntered event + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' SFDialogs.SF_DialogControl.OnMouseEntered (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant +''' Get the script associated with the OnMouseExited event + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' SFDialogs.SF_DialogControl.OnMouseExited (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant +''' Get the script associated with the OnMouseMoved event + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' SFDialogs.SF_DialogControl.OnMouseMoved (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant +''' Get the script associated with the OnMousePressed event + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' SFDialogs.SF_DialogControl.OnMousePressed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant +''' Get the script associated with the OnMouseReleased event + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' SFDialogs.SF_DialogControl.OnMouseReleased (get) + +REM ----------------------------------------------------------------------------- +Property Get OnNodeExpanded() As Variant +''' Get the script associated with the OnNodeExpanded event + OnNodeExpanded = _PropertyGet("OnNodeExpanded") +End Property ' SFDialogs.SF_DialogControl.OnNodeExpanded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnNodeExpanded(Optional ByVal pvOnNodeExpanded As Variant) +''' Set the updatable property OnNodeExpanded + _PropertySet("OnNodeExpanded", pvOnNodeExpanded) +End Property ' SFDialogs.SF_DialogControl.OnNodeExpanded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnNodeSelected() As Variant +''' Get the script associated with the OnNodeSelected event + OnNodeSelected = _PropertyGet("OnNodeSelected") +End Property ' SFDialogs.SF_DialogControl.OnNodeSelected (get) + +REM ----------------------------------------------------------------------------- +Property Let OnNodeSelected(Optional ByVal pvOnNodeSelected As Variant) +''' Set the updatable property OnNodeSelected + _PropertySet("OnNodeSelected", pvOnNodeSelected) +End Property ' SFDialogs.SF_DialogControl.OnNodeSelected (let) + +REM ----------------------------------------------------------------------------- +Property Get OnTextChanged() As Variant +''' Get the script associated with the OnTextChanged event + OnTextChanged = _PropertyGet("OnTextChanged") +End Property ' SFDialogs.SF_DialogControl.OnTextChanged (get) + +REM ----------------------------------------------------------------------------- +Property Get Page() As Variant +''' A dialog may have several pages that can be traversed by the user step by step. The Page property of the Dialog object defines which page of the dialog is active. +''' The Page property of a control defines the page of the dialog on which the control is visible. +''' For example, if a control has a page value of 1, it is only visible on page 1 of the dialog. +''' If the page value of the dialog is increased from 1 to 2, then all controls with a page value of 1 disappear and all controls with a page value of 2 become visible. + Page = _PropertyGet("Page") +End Property ' SFDialogs.SF_DialogControl.Page (get) + +REM ----------------------------------------------------------------------------- +Property Let Page(Optional ByVal pvPage As Variant) +''' Set the updatable property Page + _PropertySet("Page", pvPage) +End Property ' SFDialogs.SF_DialogControl.Page (let) + +REM ----------------------------------------------------------------------------- +Property Get Parent() As Object +''' Return the Parent dialog object of the actual control + Parent = _PropertyGet("Parent", Nothing) +End Property ' SFDialogs.SF_DialogControl.Parent + +REM ----------------------------------------------------------------------------- +Property Get Picture() As Variant +''' The Picture property specifies a bitmap or other type of graphic to be displayed on the specified control + Picture = _PropertyGet("Picture", "") +End Property ' SFDialogs.SF_DialogControl.Picture (get) + +REM ----------------------------------------------------------------------------- +Property Let Picture(Optional ByVal pvPicture As Variant) +''' Set the updatable property Picture + _PropertySet("Picture", pvPicture) +End Property ' SFDialogs.SF_DialogControl.Picture (let) + +REM ----------------------------------------------------------------------------- +Property Get RootNode() As Variant +''' The RootNode property returns the last root node of a tree control + RootNode = _PropertyGet("RootNode", "") +End Property ' SFDialogs.SF_DialogControl.RootNode (get) + +REM ----------------------------------------------------------------------------- +Property Get RowSource() As Variant +''' The RowSource property specifies the data contained in a combobox or a listbox +''' as a zero-based array of string values + RowSource = _PropertyGet("RowSource", "") +End Property ' SFDialogs.SF_DialogControl.RowSource (get) + +REM ----------------------------------------------------------------------------- +Property Let RowSource(Optional ByVal pvRowSource As Variant) +''' Set the updatable property RowSource + _PropertySet("RowSource", pvRowSource) +End Property ' SFDialogs.SF_DialogControl.RowSource (let) + +REM ----------------------------------------------------------------------------- +Property Get Text() As Variant +''' The Text property specifies the actual content of the control like it is displayed on the screen + Text = _PropertyGet("Text", "") +End Property ' SFDialogs.SF_DialogControl.Text (get) + +REM ----------------------------------------------------------------------------- +Property Get TipText() As Variant +''' The TipText property specifies the text that appears in a screentip when you hold the mouse pointer over a control + TipText = _PropertyGet("TipText", "") +End Property ' SFDialogs.SF_DialogControl.TipText (get) + +REM ----------------------------------------------------------------------------- +Property Let TipText(Optional ByVal pvTipText As Variant) +''' Set the updatable property TipText + _PropertySet("TipText", pvTipText) +End Property ' SFDialogs.SF_DialogControl.TipText (let) + +REM ----------------------------------------------------------------------------- +Property Get TripleState() As Variant +''' The TripleState property specifies how a check box will display Null values +''' When True, the control will cycle through states for Yes, No, and Null values. The control appears dimmed (grayed) when its Value property is set to Null. +''' When False, the control will cycle through states for Yes and No values. Null values display as if they were No values. + TripleState = _PropertyGet("TripleState", False) +End Property ' SFDialogs.SF_DialogControl.TripleState (get) + +REM ----------------------------------------------------------------------------- +Property Let TripleState(Optional ByVal pvTripleState As Variant) +''' Set the updatable property TripleState + _PropertySet("TripleState", pvTripleState) +End Property ' SFDialogs.SF_DialogControl.TripleState (let) + +REM ----------------------------------------------------------------------------- +Property Get Value() As Variant +''' The Value property specifies the data contained in the control + Value = _PropertyGet("Value", Empty) +End Property ' SFDialogs.SF_DialogControl.Value (get) + +REM ----------------------------------------------------------------------------- +Property Let Value(Optional ByVal pvValue As Variant) +''' Set the updatable property Value + _PropertySet("Value", pvValue) +End Property ' SFDialogs.SF_DialogControl.Value (let) + +REM ----------------------------------------------------------------------------- +Property Get Visible() As Variant +''' The Visible property specifies if the control is accessible with the cursor. + Visible = _PropertyGet("Visible", True) +End Property ' SFDialogs.SF_DialogControl.Visible (get) + +REM ----------------------------------------------------------------------------- +Property Let Visible(Optional ByVal pvVisible As Variant) +''' Set the updatable property Visible + _PropertySet("Visible", pvVisible) +End Property ' SFDialogs.SF_DialogControl.Visible (let) + +REM ----------------------------------------------------------------------------- +Property Get XControlModel() As Object +''' The XControlModel property returns the model UNO object of the control + XControlModel = _PropertyGet("XControlModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XControlModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XControlView() As Object +''' The XControlView property returns the view UNO object of the control + XControlView = _PropertyGet("XControlView", Nothing) +End Property ' SFDialogs.SF_DialogControl.XControlView (get) + +REM ----------------------------------------------------------------------------- +Property Get XGridColumnModel() As Object +''' The XGridColumnModel property returns the mutable data model UNO object of the tree control + XGridColumnModel = _PropertyGet("XGridColumnModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XGridColumnModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XGridDataModel() As Object +''' The XGridDataModel property returns the mutable data model UNO object of the tree control + XGridDataModel = _PropertyGet("XGridDataModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XGridDataModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XTreeDataModel() As Object +''' The XTreeDataModel property returns the mutable data model UNO object of the tree control + XTreeDataModel = _PropertyGet("XTreeDataModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XTreeDataModel (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AddSubNode(Optional ByRef ParentNode As Variant _ + , Optional ByVal DisplayValue As Variant _ + , Optional ByRef DataValue As Variant _ + ) As Variant +''' Return a new node of the tree control subordinate to a parent node +''' Args: +''' ParentNode: A node UNO object, of type com.sun.star.awt.tree.XMutableTreeNode +''' DisplayValue: the text appearing in the control box +''' DataValue: any value associated with the new node. Default = Empty +''' Returns: +''' The new node UNO object: com.sun.star.awt.tree.XMutableTreeNode +''' Examples: +''' Dim myTree As Object, myNode As Object, theRoot As Object +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set theRoot = myTree.CreateRoot("Tree top") +''' Set myNode = myTree.AddSubNode(theRoot, "A branch ...") + +Dim oNode As Object ' Return value +Const cstThisSub = "SFDialogs.DialogControl.AddSubNode" +Const cstSubArgs = "ParentNode, DisplayValue, [DataValue=Empty]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oNode = Nothing + +Check: + If IsMissing(DataValue) Then DataValue = Empty + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(ParentNode, "ParentNode", V_OBJECT) Then GoTo Catch + If ScriptForge.SF_Session.UnoObjectType(ParentNode) <> "toolkit.MutableTreeNode" Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch + End If + +Try: + With _TreeDataModel + Set oNode = .createNode(DisplayValue, True) + oNode.DataValue = DataValue + ParentNode.appendChild(oNode) + End With + +Finally: + Set AddSubNode = oNode + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "AddSubNode") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.AddSubNode + +REM ----------------------------------------------------------------------------- +Public Function AddSubTree(Optional ByRef ParentNode As Variant _ + , Optional ByRef FlatTree As Variant _ + , Optional ByVal WithDataValue As Variant _ + ) As Boolean +''' Return True when a subtree, subordinate to a parent node, could be inserted successfully in a tree control +''' If the parent node had already child nodes before calling this method, the child nodes are erased +''' Args: +''' ParentNode: A node UNO object, of type com.sun.star.awt.tree.XMutableTreeNode +''' FlatTree: a 2D array sorted on the columns containing the DisplayValues +''' Flat tree >>>> Resulting subtree +''' A1 B1 C1 |__ A1 +''' A1 B1 C2 |__ B1 +''' A1 B2 C3 |__ C1 +''' A2 B3 C4 |__ C2 +''' A2 B3 C5 |__ B2 +''' A3 B4 C6 |__ C3 +''' |__ A2 +''' |__ B3 +''' |__ C4 +''' |__ C5 +''' |__ A3 +''' |__ B4 +''' |__ C6 +''' Typically, such an array can be issued by the GetRows method applied on the SFDatabases.Database service +''' when an array item containing the text to be displayed is = "" or is empty/null, +''' no new subnode is created and the remainder of the row is skipped +''' When AddSubTree() is called from a Python script, FlatTree may be an array of arrays +''' WithDataValue: +''' When False (default), every column of FlatTree contains the text to be displayed in the tree control +''' When True, the texts to be displayed (DisplayValue) are in columns 0, 2, 4, ... +''' while the DataValues are in columns 1, 3, 5, ... +''' Returns: +''' True when successful +''' Examples: +''' Dim myTree As Object, theRoot As Object, oDb As Object, vData As Variant +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set theRoot = myTree.CreateRoot("By product category") +''' Set oDb = CreateScriptService("SFDatabases.Database", "/home/.../mydatabase.odb") +''' vData = oDb.GetRows("SELECT [Category].[Name], [Category].[ID], [Product].[Name], [Product].[ID] " _ +''' & "FROM [Category], [Product] WHERE [Product].[CategoryID] = [Category].[ID] " _ +''' & "ORDER BY [Category].[Name], [Product].[Name]") +''' myTree.AddSubTree(theRoot, vData, WithDataValue := True) + +Dim bSubTree As Boolean ' Return value +Dim oNode As Object ' com.sun.star.awt.tree.XMutableTreeNode +Dim oNewNode As Object ' com.sun.star.awt.tree.XMutableTreeNode +Dim lChildCount As Long ' Number of children nodes of a parent node +Dim iStep As Integer ' 1 when WithDataValue = False, 2 otherwise +Dim iDims As Integer ' Number of dimensions of FlatTree +Dim lMin1 As Long ' Lower bound (rows) +Dim lMin2 As Long ' Lower bounds (cols) +Dim lMax1 As Long ' Upper bound (rows) +Dim lMax2 As Long ' Upper bounds (cols) +Dim vFlatItem As Variant ' A single FlatTree item: FlatTree(i, j) +Dim vFlatItem2 As Variant ' A single FlatTree item +Dim bChange As Boolean ' When True, the item in FlatTree is different from the item above +Dim sValue As String ' Alias for display values +Dim i As Long, j As Long +Const cstThisSub = "SFDialogs.DialogControl.AddSubTree" +Const cstSubArgs = "ParentNode, FlatTree, [WithDataValue=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSubTree = False + +Check: + If IsMissing(WithDataValue) Or IsEmpty(WithDataValue) Then WithDataValue = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(ParentNode, "ParentNode", V_OBJECT) Then GoTo Catch + If ScriptForge.SF_Session.UnoObjectType(ParentNode) <> "toolkit.MutableTreeNode" Then GoTo Catch + If Not ScriptForge.SF_Utils._ValidateArray(FlatTree, "FlatTree") Then GoTo Catch ' Dimensions checked below + If Not ScriptForge.SF_Utils._Validate(WithDataValue, "WithDataValue", V_BOOLEAN) Then GoTo Catch + End If + +Try: + With _TreeDataModel + ' Clean subtree + lChildCount = ParentNode.getChildCount() + For i = 1 To lChildCount + ParentNode.removeChildByIndex(0) ' This cleans all subtrees too + Next i + + ' Determine bounds + iDims = ScriptForge.SF_Array.CountDims(FlatTree) + Select Case iDims + Case -1, 0 : GoTo Catch + Case 1 ' Called probably from Python + lMin1 = LBound(FlatTree, 1) : lMax1 = UBound(FlatTree, 1) + If Not IsArray(FlatTree(0)) Then GoTo Catch + If UBound(FlatTree(0)) < LBound(FlatTree(0)) Then GoTo Catch ' No columns + lMin2 = LBound(FlatTree(0)) : lMax2 = UBound(FlatTree(0)) + Case 2 + lMin1 = LBound(FlatTree, 1) : lMax1 = UBound(FlatTree, 1) + lMin2 = LBound(FlatTree, 2) : lMax2 = UBound(FlatTree, 2) + Case Else : GoTo Catch + End Select + + ' Build a new subtree + iStep = Iif(WithDataValue, 2, 1) + For i = lMin1 To lMax1 + bChange = ( i = 0 ) + ' Restart from the parent node at each i-iteration + Set oNode = ParentNode + For j = lMin2 To lMax2 Step iStep ' Array columns + If iDims = 1 Then vFlatItem = FlatTree(i)(j) Else vFlatItem = FlatTree(i, j) + If vFlatItem = "" Or IsNull(vFlatItem) Or IsEmpty(vFlatItem) Then + Set oNode = Nothing + Exit For ' Exit j-loop + End If + If Not bChange Then + If iDims = 1 Then vFlatItem2 = FlatTree(i - 1)(j) Else vFlatItem2 = FlatTree(i - 1, j) + bChange = ( vFlatItem <> vFlatItem2 ) + End If + If bChange Then ' Create new subnode at tree depth = j + If VarType(vFlatItem) = V_STRING Then sValue = vFlatItem Else sValue = ScriptForge.SF_String.Represent(vFlatItem) + Set oNewNode = .createNode(sValue, True) + If WithDataValue Then + If iDims = 1 Then vFlatItem2 = FlatTree(i)(j + 1) Else vFlatItem2 = FlatTree(i, j + 1) + oNewNode.DataValue = vFlatItem2 + End If + oNode.appendChild(oNewNode) + Set oNode = oNewNode + Else + ' Position next current node on last child of actual current node + lChildCount = oNode.getChildCount() + If lChildCount > 0 Then Set oNode = oNode.getChildAt(lChildCount - 1) Else Set oNode = Nothing + End If + Next j + Next i + bSubTree = True + End With + +Finally: + AddSubTree = bSubTree + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "AddSubTree") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.AddSubTree + +REM ----------------------------------------------------------------------------- +Public Function CreateRoot(Optional ByVal DisplayValue As Variant _ + , Optional ByRef DataValue As Variant _ + ) As Variant +''' Return a new root node of the tree control. The new tree root is inserted below pre-existing root nodes +''' Args: +''' DisplayValue: the text appearing in the control box +''' DataValue: any value associated with the root node. Default = Empty +''' Returns: +''' The new root node as a UNO object of type com.sun.star.awt.tree.XMutableTreeNode +''' Examples: +''' Dim myTree As Object, myNode As Object +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set myNode = myTree.CreateRoot("Tree starts here ...") + +Dim oRoot As Object ' Return value +Const cstThisSub = "SFDialogs.DialogControl.CreateRoot" +Const cstSubArgs = "DisplayValue, [DataValue=Empty]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oRoot = Nothing + +Check: + If IsMissing(DataValue) Then DataValue = Empty + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch + End If + +Try: + With _TreeDataModel + Set oRoot = .createNode(DisplayValue, True) + oRoot.DataValue = DataValue + .setRoot(oRoot) + ' To be visible, a root must have contained at least 1 child. Create a fictive one and erase it. + ' This behaviour does not seem related to the RootDisplayed property ?? + oRoot.appendChild(.createNode("Something", False)) + oRoot.removeChildByIndex(0) + End With + +Finally: + Set CreateRoot = oRoot + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "CreateRoot") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.CreateRoot + +REM ----------------------------------------------------------------------------- +Public Function FindNode(Optional ByVal DisplayValue As String _ + , Optional ByRef DataValue As Variant _ + , Optional ByVal CaseSensitive As Boolean _ + ) As Object +''' Traverses the tree and find recursively, starting from the root, a node meeting some criteria +''' Either (1 match is enough): +''' having its DisplayValue like DisplayValue +''' having its DataValue = DataValue +''' Comparisons may be or not case-sensitive +''' The first matching occurrence is returned +''' Args: +''' DisplayValue: the pattern to be matched +''' DataValue: a string, a numeric value or a date or Empty (if not applicable) +''' CaseSensitive: applicable on both criteria. Default = False +''' Returns: +''' The found node of type com.sun.star.awt.tree.XMutableTreeNode or Nothing if not found +''' Examples: +''' Dim myTree As Object, myNode As Object +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set myNode = myTree.FindNode("*Sophie*", CaseSensitive := True) + + +Dim oNode As Object ' Return value +Const cstThisSub = "SFDialogs.DialogControl.FindNode" +Const cstSubArgs = "[DisplayValue=""""], [DataValue=Empty], [CaseSensitive=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oNode = Nothing + +Check: + If IsMissing(DisplayValue) Or IsEmpty(DisplayValue) Then DisplayValue = "" + If IsMissing(DataValue) Then DataValue = Empty + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Catch + End If + +Try: + Set oNode = _FindNode(_TreeDataModel.getRoot(), DisplayValue, DataValue, CaseSensitive) + +Finally: + Set FindNode = oNode + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "FindNode") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.FindNode + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "SFDialogs.DialogControl.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "AddSubNode" _ + , "AddSubTree" _ + , "CreateRoot" _ + , "FindNode" _ + , "SetFocus" _ + , "WriteLine" _ + ) + +End Function ' SFDialogs.SF_DialogControl.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "Cancel" _ + , "Caption" _ + , "ControlType" _ + , "CurrentNode" _ + , "Default" _ + , "Enabled" _ + , "Format" _ + , "ListCount" _ + , "ListIndex" _ + , "Locked" _ + , "MultiSelect" _ + , "Name" _ + , "OnActionPerformed" _ + , "OnAdjustmentValueChanged" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnItemStateChanged" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "OnNodeExpanded" _ + , "OnNodeSelected" _ + , "OnTextChanged" _ + , "Page" _ + , "Parent" _ + , "Picture" _ + , "RootNode" _ + , "RowSource" _ + , "Text" _ + , "TipText" _ + , "TripleState" _ + , "Value" _ + , "Visible" _ + , "XControlModel" _ + , "XControlView" _ + , "XGridColumnModel" _ + , "XGridDataModel" _ + , "XTreeDataModel" _ + ) + +End Function ' SFDialogs.SF_DialogControl.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetFocus() As Boolean +''' Set the focus on the current Control instance +''' Probably called from after an event occurrence +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' Dim oDlg As Object, oControl As Object +''' Set oDlg = CreateScriptService(,, "myControl") ' Control stored in current document's standard library +''' Set oControl = oDlg.Controls("thisControl") +''' oControl.SetFocus() + +Dim bSetFocus As Boolean ' Return value +Const cstThisSub = "SFDialogs.DialogControl.SetFocus" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSetFocus = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + End If + +Try: + If Not IsNull(_ControlView) Then + _ControlView.setFocus() + bSetFocus = True + End If + +Finally: + SetFocus = bSetFocus + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFControls.SF_DialogControl.SetFocus + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDialogs.DialogControl.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SetTableData(Optional ByRef DataArray As Variant _ + , Optional ByRef Widths As Variant _ + , Optional ByRef Alignments As Variant _ + ) As Boolean +''' Fill a table control with the given data. Preexisting data is erased +''' The Basic IDE allows to define if the control has a row and/or a column header +''' When it is the case, the array in argument should contain those headers resp. in the first +''' column and/or in the first row +''' A column in the control shall be sortable when the data (headers excluded) in that column +''' is homogeneously filled either with numbers or with strings +''' Columns containing strings will be left-aligned, those with numbers will be right-aligned +''' Args: +''' DataArray: the set of data to display in the table control, including optional column/row headers +''' Is a 2D array in Basic, is a tuple of tuples when called from Python +''' Widths: the column's relative widths as a 1D array, each element corresponding with a column +''' If the array is shorter than the number of columns, the last value is kept for the next columns. +''' Example: +''' Widths := Array(1, 2) +''' means that the first column is half as wide as all the other columns +''' When the argument is absent, the columns are evenly spread over the control +''' Alignments: the column's horizontal alignment as a string with length = number of columns. +''' Possible characters are: +''' L(EFT), C(ENTER), R(IGHT) or space (default behaviour) +''' Returns: +''' True when successful +''' Examples: +''' Dim myTable As Object, bSet As Boolean, vData As Variant +''' Set myTable = myDialog.Controls("myTableControl") ' This control has only column headers +''' vData = Array("Col1", "Col2", "Col3") +''' vData = SF_Array.AppendRow(vData, Array(1, 2, 3)) +''' vData = SF_Array.AppendRow(vData, Array(4, 5, 6)) +''' vData = SF_Array.AppendRow(vData, Array(7, 8, 9)) +''' bSet = myTable.SetTableData(vData, Alignments := " C ") + +Dim bData As Boolean ' Return value +Dim iDims As Integer ' Number of dimensions of DataArray +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim lControlWidth As Long ' Width of the table control +Dim lMinW As Long ' lBound of Widths +Dim lMaxW As Long ' UBound of vWidths +Dim lMinRow As Long ' Row index of effective data subarray +Dim lMinCol As Long ' Column index of effective data subarray +Dim vRowHeaders As Variant ' Array of row headers +Dim sRowHeader As String ' A single row header +Dim vColHeaders As Variant ' Array of column headers +Dim oColumn As Object ' com.sun.star.awt.grid.XGridColumn +Dim dWidth As Double ' A single item of Widths +Dim dRelativeWidth As Double ' Sum of Widths up to the number of columns +Dim dWidthFactor As Double ' Factor to apply to relative widths to get absolute column widths +Dim vDataRow As Variant ' A single row content in the tablecontrol +Dim vDataItem As Variant ' A single DataArray item +Dim sAlign As String ' Column's horizontal alignments (single chars: L, C, R, space) +Dim lAlign As Long ' com.sun.star.style.HorizontalAlignment.XXX +Dim i As Long, j As Long, k As Long + +Const cstRowHdrWidth = 12 ' Estimated width of the row header + +Const cstThisSub = "SFDialogs.DialogControl.SetTableData" +Const cstSubArgs = "DataArray, [Widths=Array(1)], [Alignments=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bData = False + +Check: + If IsMissing(Widths) Or IsEmpty(Widths) Then Widths = Array(1) + If IsMissing(Alignments) Or IsEmpty(Alignments) Then Alignments = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTABLECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._ValidateArray(DataArray, "DataArray") Then GoTo Catch ' Dimensions are checked below + If Not ScriptForge.SF_Utils._ValidateArray(Widths, "Widths", 1, ScriptForge.V_NUMERIC, True) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Alignments, "Alignments", V_STRING) Then GoTo Catch + End If + +Try: + ' Erase any pre-existing data and columns + _GridDataModel.removeAllRows() + For i = _GridColumnModel.ColumnCount - 1 To 0 Step -1 + _GridColumnModel.removeColumn(i) + Next i + + ' LBounds, UBounds - Basic or Pytho + iDims = ScriptForge.SF_Array.CountDims(DataArray) + Select Case iDims + Case -1, 0 : GoTo Catch + Case 1 ' Called probably from Python + lMin1 = LBound(DataArray, 1) : lMax1 = UBound(DataArray, 1) + If Not IsArray(DataArray(0)) Then GoTo Catch + If UBound(DataArray(0)) < LBound(DataArray(0)) Then GoTo Catch ' No columns + lMin2 = LBound(DataArray(0)) : lMax2 = UBound(DataArray(0)) + Case 2 + lMin1 = LBound(DataArray, 1) : lMax1 = UBound(DataArray, 1) + lMin2 = LBound(DataArray, 2) : lMax2 = UBound(DataArray, 2) + Case Else : GoTo Catch + End Select + + ' Extract headers from data array + lMinW = LBound(Widths) : lMaxW = UBound(Widths) + With _ControlModel + If .ShowColumnHeader Then + lMinRow = lMin1 + 1 + If iDims = 1 Then + vColHeaders = DataArray(lMin1) + Else + vColHeaders = ScriptForge.SF_Array.ExtractRow(DataArray, lMin1) + End If + Else + lMinRow = lMin1 + vColHeaders = Array() + End If + If .ShowRowHeader Then + lMinCol = lMin2 + 1 + If iDims = 1 Then + vRowHeaders = Array() + ReDim vRowHeaders(lMin1 To lMax1) + For i = lMin1 To lMax1 + vRowHeaders(i) = DataArray(i)(lMin2) + Next i + Else + vRowHeaders = ScriptForge.SF_Array.ExtractColumn(DataArray, lMin2) + End If + Else + lMinCol = lMin2 + vRowHeaders = Array() + End If + End With + + ' Create the columns + For j = lMinCol To lMax2 + Set oColumn = _GridColumnModel.createColumn() + If _ControlModel.ShowColumnHeader Then oColumn.Title = vColHeaders(j) + _GridColumnModel.addColumn(oColumn) + Next j + ' Size the columns. Column sizing cannot be done before all the columns are added + If lMaxW >= lMinW Then ' There must be at least 1 width given as argument + ' Size the columns proportionally with their relative widths + dRelativeWidth = 0.0 + i = lMinW - 1 + ' Compute the sum of the relative widths + For j = 0 To lMax2 - lMinCol + i = i + 1 + If i >= lMinW And i <= lMaxW Then dRelativeWidth = dRelativeWidth + Widths(i) Else dRelativeWidth = dRelativeWidth + Widths(lMaxW) + Next j + ' Set absolute widths + If dRelativeWidth > 0.0 Then dWidthFactor = CDbl((_ControlModel.Width - cstRowHdrWidth) / dRelativeWidth) Else dWidthFactor = 1.0 + i = lMinW - 1 + For j = 0 To lMax2 - lMinCol + i = i + 1 + If i >= lMinW And i <= lMaxW Then dWidth = CDbl(Widths(i)) Else dWidth = CDbl(Widths(lMaxW)) + _GridColumnModel.Columns(j).ColumnWidth = CLng(dWidthFactor * dWidth) + Next j + Else + ' Size all columns evenly + For j = 0 To lMax2 - lMinCol + _GridColumnModel.Columns(j).ColumnWidth = (_ControlModel.Width - cstRowHdrWidth) / (lMax2 - lMonCol + 1) + Next j + End If + + ' Initialize the column alignment + If Len(Alignments) >= lMax2 - lMinCol + 1 Then sAlign = Alignments Else sAlign = Alignments & Space(lMax2 - lMinCol + 1 - Len(Alignments)) + + ' Feed the table with data and define/confirm the column alignment + vDataRow = Array() + For i = lMinRow To lMax1 + ReDim vDataRow(0 To lMax2 - lMinCol) + For j = lMinCol To lMax2 + If iDims = 1 Then vDataItem = DataArray(i)(j) Else vDataItem = DataArray(i, j) + If VarType(vDataItem) = V_STRING Then + ElseIf ScriptForge.SF_Utils._VarTypeExt(vDataItem) = ScriptForge.V_NUMERIC Then + Else + vDataItem = ScriptForge.SF_String.Represent(vDataItem) + End If + vDataRow(j - lMinCol) = vDataItem + ' Store alignment while processing the first row of the array + If i = lMinRow Then + k = j - lMinCol + 1 + If Mid(sAlign, k, 1) = " " Then Mid(sAlign, k, 1) = Iif(VarType(vDataItem) = V_STRING, "L", "R") + End If + Next j + If _ControlModel.ShowRowHeader Then sRowHeader = vRowHeaders(i) Else sRowHeader = "" + _GridDataModel.addRow(sRowHeader, vDataRow) + Next i + + ' Determine alignments of each column + For j = 0 To lMax2 - lMinCol + Select Case Mid(sAlign, j + 1, 1) + Case "L", " " : lAlign = com.sun.star.style.HorizontalAlignment.LEFT + Case "R" : lAlign = com.sun.star.style.HorizontalAlignment.RIGHT + Case "C" : lAlign = com.sun.star.style.HorizontalAlignment.CENTER + Case Else + End Select + _GridColumnModel.Columns(j).HorizontalAlign = lAlign + Next j + + bData = True + +Finally: + SetTableData = bData + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "SetTableData") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.SetTableData + +REM ----------------------------------------------------------------------------- +Public Function WriteLine(Optional ByVal Line As Variant) As Boolean +''' Add a new line to a multiline TextField control +''' Args: +''' Line: (default = "") the line to insert at the end of the text box +''' a newline character will be inserted before the line, if relevant +''' Returns: +''' True if insertion is successful +''' Exceptions +''' TEXTFIELDERROR Method applicable on multiline text fields only +''' Example: +''' Dim oDlg As Object, oControl As Object +''' Set oDlg = CreateScriptService(,, "myControl") ' Control stored in current document's standard library +''' Set oControl = oDlg.Controls("thisControl") +''' oControl.WriteLine("a new line") + +Dim bWriteLine As Boolean ' Return value +Dim lTextLength As Long ' Actual length of text in box +Dim oSelection As New com.sun.star.awt.Selection +Dim sNewLine As String ' Newline character(s) +Const cstThisSub = "SFDialogs.DialogControl.WriteLine" +Const cstSubArgs = "[Line=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bWriteLine = False + +Check: + If IsMissing(Line) Or IsEmpty(Line) Then Line = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Line, "Line", V_STRING) Then GoTo Finally + End If + If ControlType <> CTLTEXTFIELD Then GoTo CatchField + If _ControlModel.MultiLine = False Then GoTo CatchField + +Try: + _ControlModel.HardLineBreaks = True + sNewLine = ScriptForge.SF_String.sfNEWLINE + With _ControlView + lTextLength = Len(.getText()) + If lTextLength = 0 Then ' Text field is still empty + oSelection.Min = 0 : oSelection.Max = 0 + .setText(Line) + Else ' Put cursor at the end of the actual text + oSelection.Min = lTextLength : oSelection.Max = lTextLength + .insertText(oSelection, sNewLine & Line) + End If + ' Put the cursor at the end of the inserted text + oSelection.Max = oSelection.Max + Len(sNewLine) + Len(Line) + oSelection.Min = oSelection.Max + .setSelection(oSelection) + End With + bWriteLine = True + +Finally: + WriteLine = bWriteLine + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchField: + ScriptForge.SF_Exception.RaiseFatal(TEXTFIELDERROR, _Name, _DialogName) + GoTo Finally +End Function ' SFControls.SF_DialogControl.WriteLine + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FindNode(ByRef poNode As Object _ + , ByVal psDisplayValue As String _ + , ByRef pvDataValue As Variant _ + , ByVal pbCaseSensitive As Boolean _ + ) As Object +''' Traverses the tree and find recursively, starting from the root, a node meeting some criteria +''' Either (1 match is enough): +''' having its DisplayValue like psDisplayValue +''' having its DataValue = pvDataValue +''' Comparisons may be or not case-sensitive +''' The first matching occurrence is returned +''' Args: +''' poNode: the current node, the root at 1st call +''' psDisplayValue: the pattern to be matched +''' pvDataValue: a string, a numeric value or a date or Empty (if not applicable) +''' pbCaseSensitive: applicable on both criteria +''' Returns: +''' The found node of type com.sun.star.awt.tree.XMutableTreeNode + +Dim oChild As Object ' Child node com.sun.star.awt.tree.XMutableTreeNode +Dim oFind As Object ' Found node com.sun.star.awt.tree.XMutableTreeNode +Dim lChildCount As Long ' Number of children of a node +Dim bFound As Boolean ' True when node found +Dim i As Long + + Set _FindNode = Nothing + On Local Error GoTo Finally ' Better not found than raise an error + +Check: + ' Does the actual node match the criteria ? + bFound = False + If Len(psDisplayValue) > 0 Then + bFound = ScriptForge.SF_String.IsLike(poNode.DisplayValue, psDisplayValue, pbCaseSensitive) + End If + If Not bFound And Not IsEmpty(poNode.DataValue) Then + If Not IsEmpty(pvdataValue) Then bFound = ( ScriptForge.SF_Array._ValCompare(poNode.DataValue, pvDataB-Value, pbCaseSensitive) = 0 ) + End If + If bFound Then + Set _FindNode = poNode + Exit Function + End If + +Try: + ' Explore sub-branches + lChildCount = poNode.getChildCount + If lChildCount > 0 Then + For i = 0 To lChildCount - 1 + Set oChild = poNode.getChildAt(i) + Set oFind = _FindNode(oChild, psDisplayValue, pvDataValue, pbCaseSensitive) ' Recursive call + If Not IsNull(oFind) Then + Set _FindNode = oFind + Exit For + End If + Next i + End If + +Finally: + Exit Function +End Function ' SFDialogs.SF_DialogControl._FindNode + +REM ----------------------------------------------------------------------------- +Private Function _FormatsList() As Variant +''' Return the allowed format entries as a zero-based array for Date and Time control types + +Dim vFormats() As Variant ' Return value + + Select Case _ControlType + Case CTLDATEFIELD + vFormats = Array( _ + "Standard (short)" _ + , "Standard (short YY)" _ + , "Standard (short YYYY)" _ + , "Standard (long)" _ + , "DD/MM/YY" _ + , "MM/DD/YY" _ + , "YY/MM/DD" _ + , "DD/MM/YYYY" _ + , "MM/DD/YYYY" _ + , "YYYY/MM/DD" _ + , "YY-MM-DD" _ + , "YYYY-MM-DD" _ + ) + Case CTLTIMEFIELD + vFormats = Array( _ + "24h short" _ + , "24h long" _ + , "12h short" _ + , "12h long" _ + ) + Case Else + vFormats = Array() + End Select + + _FormatsList = vFormats + +End Function ' SFDialogs.SF_DialogControl._FormatsList + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDialogs.SF_DialogControl._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnActionPerformed") + _GetListener = "XActionListener" + Case UCase("OnAdjustmentValueChanged") + _GetListener = "XAdjustmentListener" + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnItemStateChanged") + _GetListener = "XItemListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case UCase("OnTextChanged") + _GetListener = "XTextListener" + Case Else + _GetListener = "" + End Select + +End Function ' SFDialogs.SF_DialogControl._GetListener + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Complete the object creation process: +''' - Initialization of private members +''' - Collection of specific attributes +''' - synchronization with parent dialog instance + +Dim vServiceName As Variant ' Split service name +Dim sType As String ' Last component of service name + +Try: + _ImplementationName = _ControlModel.getImplementationName() + + ' Identify the control type + vServiceName = Split(_ControlModel.getServiceName(), ".") + sType = vServiceName(UBound(vServiceName)) + Select Case sType + Case "UnoControlSpinButtonModel" + _ControlType = "" ' Not supported + Case "Edit" : _ControlType = CTLTEXTFIELD + Case "TreeControlModel" + ' Initialize the data model + _ControlType = CTLTREECONTROL + Set _ControlModel.DataModel = CreateUnoService("com.sun.star.awt.tree.MutableTreeDataModel") + Set _TreeDataModel = _ControlModel.DataModel + Case "UnoControlGridModel" + _ControlType = CTLTABLECONTROL + Set _GridColumnModel = _ControlModel.ColumnModel + Set _GridDataModel = _ControlModel.GridDataModel + Case Else : _ControlType = sType + End Select + + ' Store the SF_DialogControl object in the parent cache + Set _Parent._ControlCache(_IndexOfNames) = [Me] + +Finally: + Exit Sub +End Sub ' SFDialogs.SF_DialogControl._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvDefault As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property +''' pvDefault: the value returned when the property is not applicable on the control's type +''' Getting a non-existing property for a specific control type should +''' not generate an error to not disrupt the Basic IDE debugger + +Dim vGet As Variant ' Return value +Static oSession As Object ' Alias of SF_Session +Dim vSelection As Variant ' Alias of Model.SelectedItems or Model.Selection +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim vDate As Variant ' com.sun.star.util.Date or com.sun.star.util.Time +Dim vValues As Variant ' Array of listbox values +Dim oControlEvents As Object ' com.sun.star.container.XNameContainer +Dim sEventName As String ' Internal event name +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDialogs.DialogControl.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Finally + + If IsMissing(pvDefault) Then pvDefault = Null + _PropertyGet = pvDefault + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("Cancel") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "PushButtonType") Then _PropertyGet = ( _ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL ) + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDLINE, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If oSession.HasUNOProperty(_ControlModel, "Label") Then _PropertyGet = _ControlModel.Label + Case Else : GoTo CatchType + End Select + Case UCase("ControlType") + _PropertyGet = _ControlType + Case UCase("CurrentNode") + Select Case _ControlType + Case CTLTREECONTROL + If oSession.HasUNOMethod(_ControlView, "getSelection") Then + _PropertyGet = Empty + If _ControlModel.SelectionType <> com.sun.star.view.SelectionType.NONE Then + vSelection = _ControlView.getSelection() + If IsArray(vSelection) Then + If UBound(vSelection) >= 0 Then Set _PropertyGet = vSelection(0) + Else + Set _PropertyGet = vSelection + End If + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _PropertyGet = _ControlModel.DefaultButton + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _PropertyGet = _ControlModel.Enabled + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then _PropertyGet = _FormatsList()(_ControlModel.DateFormat) + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then _PropertyGet = _FormatsList()(_ControlModel.TimeFormat) + Case CTLFORMATTEDFIELD + If oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") And oSession.HasUNOProperty(_ControlModel, "FormatKey") Then + _PropertyGet = _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListCount") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "StringItemList") Then _PropertyGet = UBound(_ControlModel.StringItemList) + 1 + Case CTLTABLECONTROL ' Returns zero when no table data yet + If oSession.HasUNOProperty(_GridDataModel, "RowCount") Then _PropertyGet = _GridDataModel.RowCount + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + Select Case _ControlType + Case CTLCOMBOBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + _PropertyGet = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, _ControlModel.Text, CaseSensitive := True) + End If + Case CTLLISTBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + vSelection = _ControlModel.SelectedItems + If UBound(vSelection) >= 0 Then _PropertyGet = vSelection(0) + End If + Case CTLTABLECONTROL + _PropertyGet = -1 ' No row selected, no data, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectionModel") _ + And oSession.HasUNOProperty(_ControlView, "CurrentRow") Then + ' Other selection types (multi, range) not supported + If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE Then + lIndex = _ControlView.CurrentRow + If lIndex < 0 And oSession.HasUNOProperty(_ControlView, "SelectedRows") Then + If UBound(_ControlView.SelectedRows) >= 0 Then lIndex = _ControlView.SelectedRows(0) + End If + _PropertyGet = lIndex + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLLISTBOX _ + , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _PropertyGet = _ControlModel.ReadOnly + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + _PropertyGet = _ControlModel.MultiSelection + ElseIf oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: gridcontrols only TBC ?? + _PropertyGet = _ControlModel.MultiSelectionSimpleMode + End If + Case Else : GoTo CatchType + End Select + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnFocusGained"), UCase("OnFocusLost") _ + , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnTextChanged") + Set oControlEvents = _ControlModel.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & _GetEventName(psProperty) + If oControlEvents.hasByName(sEventName) Then + _PropertyGet = oControlEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case UCase("OnNodeExpanded") + Select Case _ControlType + Case CTLTREECONTROL + _PropertyGet = _OnNodeExpanded + Case Else : GoTo CatchType + End Select + Case UCase("OnNodeSelected") + Select Case _ControlType + Case CTLTREECONTROL + _PropertyGet = _OnNodeSelected + Case Else : GoTo CatchType + End Select + Case UCase("Page") + If oSession.HasUnoProperty(_ControlModel, "Step") Then _PropertyGet = _ControlModel.Step + Case UCase("Parent") + Set _PropertyGet = [_Parent] + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGECONTROL + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _PropertyGet = ScriptForge.SF_FileSystem._ConvertFromUrl(_ControlModel.ImageURL) + Case Else : GoTo CatchType + End Select + Case UCase("RootNode") + Select Case _ControlType + Case CTLTREECONTROL + _PropertyGet = _TreeDataModel.getRoot() + Case Else : GoTo CatchType + End Select + Case UCase("RowSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "StringItemList") Then + If IsArray(_ControlModel.StringItemList) Then _PropertyGet = _ControlModel.StringItemList Else _PropertyGet = Array(_ControlModel.StringItemList) + End If + Case Else : GoTo CatchType + End Select + Case UCase("Text") + Select Case _ControlType + Case CTLCOMBOBOX, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLPATTERNFIELD, CTLTEXTFIELD + If oSession.HasUnoProperty(_ControlModel, "Text") Then _PropertyGet = _ControlModel.Text + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _PropertyGet = _ControlModel.HelpText + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _PropertyGet = _ControlModel.TriState + Case Else : GoTo CatchType + End Select + Case UCase("Value") ' Default values are set here by control type, not in the 2nd argument + vGet = pvDefault + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + vGet = False + If oSession.HasUnoProperty(_ControlModel, "Toggle") Then + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = _ControlModel.State Else vGet = 2 + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String + If oSession.HasUnoProperty(_ControlModel, "Text") Then vGet = _ControlModel.Text Else vGet = "" + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If oSession.HasUnoProperty(_ControlModel, "Value") Then vGet = _ControlModel.Value Else vGet = 0 + Case CTLDATEFIELD 'Date + vGet = CDate(1) + If oSession.HasUnoProperty(_ControlModel, "Date") Then + If VarType(_ControlModel.Date) = ScriptForge.V_OBJECT Then ' com.sun.star.util.Date + Set vDate = _ControlModel.Date + vGet = DateSerial(vDate.Year, vDate.Month, vDate.Day) + End If + End If + Case CTLFORMATTEDFIELD 'String or numeric + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then vGet = _ControlModel.EffectiveValue Else vGet = "" + Case CTLLISTBOX 'String or array of strings depending on MultiSelection + ' StringItemList is the list of the items displayed in the box + ' SelectedItems is the list of the indexes in StringItemList of the selected items + ' It can go beyond the limits of StringItemList + ' It can contain multiple values even if the listbox is not multiselect + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _ + And oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + vSelection = _ControlModel.SelectedItems + vList = _ControlModel.StringItemList + If _ControlModel.MultiSelection Then vValues = Array() + For i = 0 To UBound(vSelection) + lIndex = vSelection(i) + If lIndex >= 0 And lIndex <= UBound(vList) Then + If Not _ControlModel.MultiSelection Then + vValues = vList(lIndex) + Exit For + End If + vValues = ScriptForge.SF_Array.Append(vValues, vList(lIndex)) + End If + Next i + vGet = vValues + Else + vGet = "" + End If + Case CTLPROGRESSBAR 'Numeric + If oSession.HasUnoProperty(_ControlModel, "ProgressValue") Then vGet = _ControlModel.ProgressValue Else vGet = 0 + Case CTLRADIOBUTTON 'Boolean + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) Else vGet = False + Case CTLSCROLLBAR 'Numeric + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then vGet = _ControlModel.ScrollValue Else vGet = 0 + Case CTLTABLECONTROL + vGet = Array() ' Default value when no row selected, no data, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectionModel") _ + And oSession.HasUNOProperty(_ControlView, "CurrentRow") Then + ' Other selection types (multi, range) not supported + If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE Then + lIndex = _ControlView.CurrentRow + If lIndex < 0 And oSession.HasUNOProperty(_ControlView, "SelectedRows") Then + If UBound(_ControlView.SelectedRows) >= 0 Then lIndex = _ControlView.SelectedRows(0) + End If + If lIndex >= 0 Then vGet = _GridDataModel.getRowData(lIndex) + End If + End If + Case CTLTIMEFIELD + vGet = CDate(0) + If oSession.HasUnoProperty(_ControlModel, "Time") Then + If VarType(_ControlModel.Time) = ScriptForge.V_OBJECT Then ' com.sun.star.Util.Time + Set vDate = _ControlModel.Time + vGet = TimeSerial(vDate.Hours, vDate.Minutes, vDate.Seconds) + End If + End If + Case Else : GoTo CatchType + End Select + _PropertyGet = vGet + Case UCase("Visible") + If oSession.HasUnoMethod(_ControlView, "isVisible") Then _PropertyGet = CBool(_ControlView.isVisible()) + Case UCase("XControlModel") + Set _PropertyGet = _ControlModel + Case UCase("XControlView") + Set _PropertyGet = _ControlView + Case UCase("XGridColumnModel") + Set _PropertyGet = _GridColumnModel + Case UCase("XGridDataModel") + Set _PropertyGet = _GridDataModel + Case UCase("XTreeDataModel") + Set _PropertyGet = _TreeDataModel + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + GoTo Finally +End Function ' SFDialogs.SF_DialogControl._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim vSet As Variant ' Value to set in UNO model or view property +Dim vFormats As Variant ' Format property: output of _FormatsList() +Dim iFormat As Integer ' Format property: index in vFormats +Dim vSelection As Variant ' Alias of Model.SelectedItems +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim vCtlTypes As Variant ' Array of allowed control types +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDialogs.DialogControl.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("Cancel") + Select Case _ControlType + Case CTLBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Cancel", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "PushButtonType") Then + If pvValue Then vSet = com.sun.star.awt.PushButtonType.CANCEL Else vSet = com.sun.star.awt.PushButtonType.STANDARD + _ControlModel.PushButtonType = vSet + End If + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDLINE, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Caption", V_STRING) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "Label") Then _ControlModel.Label = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("CurrentNode") + Select Case _ControlType + Case CTLTREECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, "Selection", ScriptForge.V_OBJECT) Then GoTo Finally + If oSession.UnoObjectType(pvValue) <> "toolkit.MutableTreeNode" Then GoTo CatchType + With _ControlView + .clearSelection() + If Not IsNull(pvValue) Then + .addSelection(pvValue) + ' Suspending temporarily the expansion listener avoids conflicts + If Len(_OnNodeExpanded) > 0 Then _ControlView.removeTreeExpansionListener(_ExpandListener) + .makeNodeVisible(pvValue) ' Expand parent nodes and put node in the display area + If Len(_OnNodeExpanded) > 0 Then _ControlView.addTreeExpansionListener(_ExpandListener) + End If + End With + Case Else : GoTo CatchType + End Select + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Default", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _ControlModel.DefaultButton = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Enabled", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _ControlModel.Enabled = pvValue + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD, CTLTIMEFIELD + vFormats = _FormatsList() + If Not ScriptForge.SF_Utils._Validate(pvValue, "Format", V_STRING, vFormats) Then GoTo Finally + iFormat = ScriptForge.SF_Array.IndexOf(vFormats, pvValue, CaseSensitive := False) + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then + _ControlModel.DateFormat = iFormat + ElseIf oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then + _ControlModel.TimeFormat = iFormat + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListIndex", ScriptForge.V_NUMERIC) Then GoTo Finally + Select Case _ControlType + Case CTLCOMBOBOX + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + _ControlModel.Text = _ControlModel.StringItemList(CInt(pvValue)) + End If + Case CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") Then _ControlModel.SelectedItems = Array(CInt(pvValue)) + Case CTLTABLECONTROL + If oSession.HasUNOProperty(_ControlModel, "SelectionModel") _ + And oSession.HasUNOMethod(_ControlView, "selectRow") Then + ' Other selection types (multi, range) not supported + If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE _ + And pvValue >= 0 And pvValue <= _GridDataModel.RowCount - 1 Then + _ControlView.selectRow(pvValue) + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLLISTBOX _ + , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Locked", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _ControlModel.ReadOnly = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "MultiSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then _ControlModel.MultiSelection = pvValue + If oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then _ControlModel.MultiSelectionSimpleMode = pvValue + If oSession.HasUnoProperty(_ControlModel, "SelectedItems") Then + If Not pvValue And UBound(_ControlModel.SelectedItems) > 0 Then ' Cancel selections when MultiSelect becomes False + lIndex = _ControlModel.SelectedItems(0) + _ControlModel.SelectedItems = Array(lIndex) + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("OnNodeExpanded") + Select Case _ControlType + Case CTLTREECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Finally + ' If the listener was already set, then stop it + If Len(_OnNodeExpanded) > 0 Then + _ControlView.removeTreeExpansionListener(_ExpandListener) + Set _ExpandListener = Nothing + _OnNodeExpanded = "" + End If + ' Setup a new fresh listener + If Len(pvValue) > 0 Then + Set _ExpandListener = CreateUnoListener("_SFEXP_", "com.sun.star.awt.tree.XTreeExpansionListener") + _ControlView.addTreeExpansionListener(_ExpandListener) + _OnNodeExpanded = pvValue + End If + Case Else : GoTo CatchType + End Select + Case UCase("OnNodeSelected") + Select Case _ControlType + Case CTLTREECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Finally + ' If the listener was already set, then stop it + If Len(_OnNodeSelected) > 0 Then + _ControlView.removeSelectionChangeListener(_SelectListener) + Set _SelectListener = Nothing + _OnNodeSelected = "" + End If + ' Setup a new fresh listener + If Len(pvValue) > 0 Then + Set _SelectListener = CreateUnoListener("_SFSEL_", "com.sun.star.view.XSelectionChangeListener") + _ControlView.addSelectionChangeListener(_SelectListener) + _OnNodeSelected = pvValue + End If + Case Else : GoTo CatchType + End Select + Case UCase("Page") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Page", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Step") Then _ControlModel.Step = CLng(pvValue) + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGECONTROL + If Not ScriptForge.SF_Utils._ValidateFile(pvValue, "Picture") Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _ControlModel.ImageURL = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue) + Case Else : GoTo CatchType + End Select + Case UCase("RowSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If Not IsArray(pvValue) Then + If Not ScriptForge.SF_Utils._Validate(pvValue, "RowSource", V_STRING) Then GoTo Finally + pvArray = Array(pvArray) + ElseIf Not ScriptForge.SF_Utils._ValidateArray(pvValue, "RowSource", 1, V_STRING, True) Then + GoTo Finally + End If + If oSession.HasUnoProperty(_ControlModel, "StringItemList") Then _ControlModel.StringItemList = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + If Not ScriptForge.SF_Utils._Validate(pvValue, "TipText", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _ControlModel.HelpText = pvValue + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "TripleState", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _ControlModel.TriState = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Value") + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Toggle") And oSession.HasUnoProperty(_ControlModel, "State") Then + _ControlModel.State = Iif(pvValue, 1, 0) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(ScriptForge.V_BOOLEAN, ScriptForge.V_NUMERIC), Array(0, 1, 2, True, False)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then + If VarType(pvValue) = ScriptForge.V_BOOLEAN Then pvValue = Iif(pvValue, 1, 0) + _ControlModel.State = pvValue + End If + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Text") Then _ControlModel.Text = pvValue + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Value") Then _ControlModel.Value = pvValue + Case CTLDATEFIELD 'Date + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Date") Then + Set vSet = New com.sun.star.util.Date + vSet.Year = Year(pvValue) + vSet.Month = Month(pvValue) + vSet.Day = Day(pvValue) + _ControlModel.Date = vSet + End If + Case CTLFORMATTEDFIELD 'String or numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then _ControlModel.EffectiveValue = pvValue + Case CTLLISTBOX 'String or array of strings depending on MultiSelection + ' StringItemList is the list of the items displayed in the box + ' SelectedItems is the list of the indexes in StringItemList of the selected items + ' It can go beyond the limits of StringItemList + ' It can contain multiple values even if the listbox is not multiselect + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _ + And oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + vSelection = Array() + If _ControlModel.MultiSelection Then + If Not ScriptForge.SF_Utils._ValidateArray(pvValue, "Value", 1, V_STRING, True) Then GoTo Finally + vList = _ControlModel.StringItemList + For i = LBound(pvValue) To UBound(pvValue) + sItem = pvValue(i) + lIndex = ScriptForge.SF_Array.IndexOf(vList, sItem) + If lIndex >= 0 Then vSelection = ScriptForge.SF_Array.Append(vSelection, lIndex) + Next i + Else + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + lIndex = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, pvValue) + If lIndex >= 0 Then vSelection = Array(lIndex) + End If + _ControlModel.SelectedItems = vSelection + End If + Case CTLPROGRESSBAR 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ProgressValueMin") Then + If pvValue < _ControlModel.ProgressValueMin Then pvValue = _ControlModel.ProgressValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "ProgressValueMax") Then + If pvValue > _ControlModel.ProgressValueMax Then pvValue = _ControlModel.ProgressValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "ProgressValue") Then _ControlModel.ProgressValue = pvValue + Case CTLRADIOBUTTON 'Boolean + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then _ControlModel.State = Iif(pvValue, 1, 0) + Case CTLSCROLLBAR 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMin") Then + If pvValue < _ControlModel.ScrollValueMin Then pvValue = _ControlModel.ScrollValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMax") Then + If pvValue > _ControlModel.ScrollValueMax Then pvValue = _ControlModel.ScrollValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then _ControlModel.ScrollValue = pvValue + Case CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Time") Then + Set vSet = New com.sun.star.util.Time + vSet.Hours = Hour(pvValue) + vSet.Minutes = Minute(pvValue) + vSet.Seconds = Second(pvValue) + _ControlModel.Time = vSet + End If + Case Else : GoTo CatchType + End Select + Case UCase("Visible") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Visible", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoMethod(_ControlView, "setVisible") Then + If pvValue Then + If oSession.HasUnoProperty(_ControlModel, "EnableVisible") Then _ControlModel.EnableVisible = True + End If + _ControlView.setVisible(pvValue) + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, psProperty) + GoTo Finally +End Function ' SFDialogs.SF_DialogControl._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DIALOGCONTROL]: Name, Type (dialogname) + _Repr = "[DIALOGCONTROL]: " & _Name & ", " & _ControlType & " (" & _DialogName & ")" + +End Function ' SFDialogs.SF_DialogControl._Repr + +REM ============================================ END OF SFDIALOGS.SF_DIALOGCONTROL + \ No newline at end of file diff --git a/wizards/source/sfdialogs/SF_DialogListener.xba b/wizards/source/sfdialogs/SF_DialogListener.xba new file mode 100644 index 000000000..0f324b609 --- /dev/null +++ b/wizards/source/sfdialogs/SF_DialogListener.xba @@ -0,0 +1,113 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDialogs library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Listener +''' =========== +''' The current module is dedicated to the management of dialog control events, triggered by user actions, +''' which cannot be defined with the Basic IDE +''' +''' Concerned events: +''' TreeControl control type +''' ----------- +''' The OnNodeSelected event, triggered when a user selects a node +''' A typical action is to display additional info about the selected item elsewhere in the dialog +''' The OnNodeExpanded event, triggered when a user clicks on the expansion symbol +''' A typical action is to create dynamically a subnode or a subtree below the expanded item +''' +''' The described events are processed thru UNO listeners +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================= DEFINITIONS + +REM ================================================================== EXCEPTIONS + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub _SFEXP_requestChildNodes(Optional ByRef poEvent As Object) +''' Triggered by the OnNodeExpanded event of a tree control +''' The event is triggered thru a com.sun.star.view.XTreeExpansionListener +''' The argument is passed to a user routine sstored in the SF_DialogControl instance +''' as a scripting framework URI + +Dim oControl As Object ' The SF_DialogControl object having triggered the event + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Check: + ' Ensure there is a node + If IsNull(poEvent) Or IsMissing(poEvent) Then Exit Sub + If IsNull(poEvent.Node) Then Exit Sub + +Try: + Set oControl = ScriptForge.SF_Services.CreateScriptService("SFDialogs.DialogEvent", poEvent) + ScriptForge.SF_Session._ExecuteScript(oControl.OnNodeExpanded, poEvent) + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub + +Sub _SFEXP_disposing(ByRef poEvent As Object) +End Sub + +Sub _SFEXP_treeExpanding(Optional ByRef poEvent As Object) +End Sub + +Sub _SFEXP_treeCollapsing(ByRef poEvent As Object) +End Sub + +Sub _SFEXP_treeExpanded(ByRef poEvent As Object) +End Sub + +Sub _SFEXP_treeCollapsed(ByRef poEvent As Object) +End Sub + +REM ----------------------------------------------------------------------------- +Public Sub _SFSEL_selectionChanged(Optional ByRef poEvent As Object) +''' Triggered by the OnNodeSelected event of a tree control +''' The event is triggered thru a com.sun.star.view.XSelectionChangeListener +''' The argument is passed to a user routine sstored in the SF_DialogControl instance +''' as a scripting framework URI +''' +''' Nothing happens if there are several selected nodes or none + +Dim vSelection As Variant ' Variant, not object !! +Dim oControl As Object ' The SF_DialogControl object having triggered the event + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Check: + ' Ensure there is a selection + If IsNull(poEvent) Or IsMissing(poEvent) Then Exit Sub + vSelection = poEvent.Source.getSelection() + If IsEmpty(vSelection) Or IsArray(vSelection) Then Exit Sub + +Try: + Set oControl = ScriptForge.SF_Services.CreateScriptService("SFDialogs.DialogEvent", poEvent) + ScriptForge.SF_Session._ExecuteScript(oControl.OnNodeSelected, poEvent) + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub + +Sub _SFSEL_disposing(ByRef poEvent As Object) +End Sub + +REM ============================================================= PRIVATE METHODS + +REM ============================================ END OF SFDIALOGS.SF_DIALOGLISTENER + \ No newline at end of file diff --git a/wizards/source/sfdialogs/SF_Register.xba b/wizards/source/sfdialogs/SF_Register.xba new file mode 100644 index 000000000..e81dbb069 --- /dev/null +++ b/wizards/source/sfdialogs/SF_Register.xba @@ -0,0 +1,348 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDialogs library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================= DEFINITIONS + +''' Event management of dialogs requires to being able to rebuild a Dialog object +''' from its com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl UNO instance +''' For that purpose, the started dialogs are buffered in a global array of _DialogCache types + +Type _DialogCache + Terminated As Boolean + XUnoDialog As Object + BasicDialog As Object +End Type + +REM ================================================================== EXCEPTIONS + +Private Const DIALOGNOTFOUNDERROR = "DIALOGNOTFOUNDERROR" + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Dialog", "SFDialogs.SF_Register._NewDialog") ' Reference to the function initializing the service + .RegisterEventManager("DialogEvent", "SFDialogs.SF_Register._EventManager") ' Reference to the events manager + 'TODO + End With + +End Sub ' SFDialogs.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _AddDialogToCache(ByRef pvUnoDialog As Object _ + , ByRef pvBasicDialog As Object _ + ) As Long +''' Add a new entry in the cache array with the references of the actual dialog +''' If relevant, the last entry of the cache is reused. +''' The cache is located in the global _SF_ variable +''' Args: +''' pvUnoDialog: the com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl of the dialog box +''' pvBasicDialog: its corresponding Basic object +''' Returns: +''' The index of the new or modified entry + +Dim vCache As New _DialogCache ' Entry to be added +Dim lIndex As Long ' UBound of _SF_.SFDialogs +Dim vCacheArray As Variant ' Alias of _SF_.SFDialogs + +Try: + vCacheArray = _SF_.SFDialogs + + If IsEmpty(vCacheArray) Then vCacheArray = Array() + lIndex = UBound(vCacheArray) + If lIndex < LBound(vCacheArray) Then + ReDim vCacheArray(0 To 0) + lIndex = 0 + ElseIf Not vCacheArray(lIndex).Terminated Then ' Often last entry can be reused + lIndex = lIndex + 1 + ReDim Preserve vCacheArray(0 To lIndex) + End If + + With vCache + .Terminated = False + Set .XUnoDialog = pvUnoDialog + Set .BasicDialog = pvBasicDialog + End With + vCacheArray(lIndex) = vCache + + _SF_.SFDialogs = vCacheArray + +Finally: + _AddDialogToCache = lIndex + Exit Function +End Function ' SFDialogs.SF_Register._AddDialogToCache + +REM ----------------------------------------------------------------------------- +Private Sub _CleanCacheEntry(ByVal plIndex As Long) +''' Clean the plIndex-th entry in the dialogs cache +''' Args: +''' plIndex: must fit within the actual boundaries of the cache, otherwise the request is ignored + +Dim vCache As New _DialogCache ' Cleaned entry + + With _SF_ + If Not IsArray(.SFDialogs) Then Exit Sub + If plIndex < LBound(.SFDialogs) Or plIndex > UBound(.SFDialogs) Then Exit Sub + + With vCache + .Terminated = True + Set .XUnoDialog = Nothing + Set .BasicDialog = Nothing + End With + .SFDialogs(plIndex) = vCache + End With + +Finally: + Exit Sub +End Sub ' SFDialogs.SF_Register._CleanCacheEntry + +REM ----------------------------------------------------------------------------- +Public Function _EventManager(Optional ByRef pvArgs As Variant) As Object +''' Returns a Dialog or DialogControl object corresponding with the Basic dialog +''' which triggered the event in argument +''' This method should be triggered only thru the invocation of CreateScriptService +''' Args: +''' pvEvent: com.sun.star.xxx +''' Returns: +''' the output of a Dialog or DialogControl service or Nothing +''' Example: +''' Sub TriggeredByEvent(ByRef poEvent As Object) +''' Dim oDlg As Object +''' Set oDlg = CreateScriptService("SFDialogs.DialogEvent", poEvent) +''' If Not IsNull(oDlg) Then +''' ' ... (a valid dialog or one of its controls has been identified) +''' End Sub + +Dim oSource As Object ' Return value +Dim oEventSource As Object ' Event UNO source +Dim vEvent As Variant ' Alias of pvArgs(0) +Dim sSourceType As String ' Implementation name of event source +Dim oDialog As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Dim bControl As Boolean ' True when control event + + ' Never abort while an event is processed + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Finally + Set oSource = Nothing + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vEvent = pvArgs(0) Else vEvent = Empty + If VarType(vEvent) <> ScriptForge.V_OBJECT Then GoTo Finally + If Not ScriptForge.SF_Session.HasUnoProperty(vEvent, "Source") Then GoTo Finally + +Try: + Set oEventSource = vEvent.Source + sSourceType = ScriptForge.SF_Session.UnoObjectType(oEventSource) + + Set oDialog = Nothing + Select Case True + Case sSourceType = "stardiv.Toolkit.UnoDialogControl" ' A dialog + ' Search the dialog in the cache + Set oDialog = _FindDialogInCache(oEventSource) + bControl = False + Case Left(sSourceType, 16) = "stardiv.Toolkit." ' A dialog control + Set oDialog = _FindDialogInCache(oEventSource.Context) + bControl = True + Case Else + End Select + + If Not IsNull(oDialog) Then + If bControl Then Set oSource = oDialog.Controls(oEventSource.Model.Name) Else Set oSource = oDialog + End If + +Finally: + Set _EventManager = oSource + Exit Function +End Function ' SFDialogs.SF_Register._EventManager + +REM ----------------------------------------------------------------------------- +Private Function _FindDialogInCache(ByRef poDialog As Object) As Object +''' Find the dialog based on its XUnoDialog +''' The dialog must not be terminated +''' Returns: +''' The corresponding Basic dialog part or Nothing + +Dim oBasicDialog As Object ' Return value +Dim oCache As _DialogCache ' Entry in the cache + + Set oBasicDialog = Nothing + +Try: + For Each oCache In _SF_.SFDialogs + If EqualUnoObjects(poDialog, oCache.XUnoDialog) And Not oCache.Terminated Then + Set oBasicDialog = oCache.BasicDialog + Exit For + End If + Next oCache + +Finally: + Set _FindDialogInCache = oBasicDialog + Exit Function +End Function ' SFDialogs.SF_Register._FindDialogInCache + +REM ----------------------------------------------------------------------------- +Public Function _NewDialog(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_Dialog class +''' Args: +''' Container: either "GlobalScope" or a WindowName. Default = the active window +''' see the definition of WindowName in the description of the UI service +''' Library: the name of the library hosting the dialog. Default = "Standard" +''' DialogName: The name of the dialog +''' Library and dialog names are case-sensitive +''' Context: When called from Python, the context must be provided : XSCRIPTCONTEXT +''' Returns: the instance or Nothing + +Dim oDialog As Object ' Return value +Dim vContainer As Variant ' Alias of pvArgs(0) +Dim vLibrary As Variant ' Alias of pvArgs(1) +Dim vDialogName As Variant ' Alias of pvArgs(2) +Dim oLibraries As Object ' com.sun.star.comp.sfx2.DialogLibraryContainer +Dim vContext As Variant ' com.sun.star.uno.XComponentContext +Dim oDialogProvider As Object ' com.sun.star.io.XInputStreamProvider +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim oDialogControl As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Dim vWindow As Window ' A single component +Dim sScope As String ' "application" or "document" +Dim sURI As String ' URI of the targeted dialog +Dim oUi As Object ' "UI" service +Dim bFound As Boolean ' True if WindowName is found on the desktop +Const cstService = "SFDialogs.Dialog" +Const cstGlobal = "GlobalScope" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) ' Needed when _NewDialog called from _EventManager + If UBound(pvArgs) >= 0 Then vContainer = pvArgs(0) Else vContainer = "" + If UBound(pvArgs) >= 1 Then vLibrary = pvArgs(1) + If IsEmpty(vLibrary) Then vLibrary = "Standard" + If UBound(pvArgs) >= 2 Then vDialogName = pvArgs(2) Else vDialogName = Empty ' Use Empty to force mandatory status + If Not ScriptForge.SF_Utils._Validate(vContainer, "Container", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vLibrary, "Library", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vDialogName, "DialogName", V_STRING) Then GoTo Finally + If UBound(pvArgs) >= 3 Then vContext = pvArgs(3) Else vContext = Nothing + If Not ScriptForge.SF_Utils._Validate(vContext, "DialogName", V_OBJECT) Then GoTo Finally + Set oDialog = Nothing + +Try: + ' Determine the library container hosting the dialog + Set oUi = ScriptForge.SF_Register.CreateScriptService("UI") + Set oComp = Nothing + If VarType(vContainer) = V_STRING Then + bFound = ( UCase(vContainer) = UCase(cstGlobal) ) + End If + If Not bFound Then + Select Case VarType(vContainer) + Case V_STRING + If Len(vContainer) > 0 Then + bFound = False + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + vWindow = oUi._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the argument ? + If (Len(.WindowFileName) > 0 And .WindowFileName = ScriptForge.SF_FileSystem._ConvertToUrl(vContainer)) _ + Or (Len(.WindowName) > 0 And .WindowName = vContainer) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = vContainer) Then + bFound = True + Exit Do + End If + End With + Loop + Else + bFound = True + Set oComp = StarDesktop.CurrentComponent + vWindow = oUi._IdentifyWindow(oComp) + End If + Case V_OBJECT ' com.sun.star.lang.XComponent + bFound = True + vWindow = oUi._IdentifyWindow(vContainer) + Set oComp = vContainer + End Select + If Not bFound Then GoTo CatchNotFound + If Len(vWindow.DocumentType) = 0 Then GoTo CatchNotFound + End If + + ' Determine the dialog provider + Select Case True + Case IsNull(vContext) And IsNull(oComp) ' Basic and GlobalScope + Set oDialogProvider = GetProcessServiceManager.createInstance("com.sun.star.awt.DialogProvider") + Case IsNull(vContext) And Not IsNull(oComp) ' Basic and Document + Set oDialogProvider = GetProcessServiceManager.createInstanceWithArguments("com.sun.star.awt.DialogProvider", Array(oComp)) + Case Not IsNull(vContext) And IsNull(oComp) ' Python and GlobalScope + Set oDialogProvider = vContext.getServiceManager().createInstanceWithContext("com.sun.star.awt.DialogProvider", vContext) + Case Not IsNull(vContext) And Not IsNull(oComp) ' Python and Document + Set oDialogProvider = vContext.getServiceManager().createInstanceWithArguments("com.sun.star.awt.DialogProvider", Array(oComp)) + End Select + + ' Create the graphical interface + sScope = Iif(IsNull(oComp), "application", "document") + sURI = "vnd.sun.star.script:" & vLibrary & "." & vDialogName & "?location=" & sScope + On Local Error GoTo CatchNotFound + Set oDialogControl = oDialogProvider.createDialog(sURI) + + ' Initialize the basic SF_Dialog instance to return to the user script + Set oDialog = New SF_Dialog + With oDialog + Set .[Me] = oDialog + If VarType(vContainer) = V_STRING Then ._Container = vContainer Else ._Container = vWindow.WindowName + ._Library = vLibrary + ._Name = vDialogName + Set ._DialogProvider = oDialogProvider + Set ._DialogControl = oDialogControl + ._Initialize() + End With + +Finally: + Set _NewDialog = oDialog + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(DIALOGNOTFOUNDERROR, "Service", cstService _ + , "Container", vContainer, "Library", vLibrary, "DialogName", vDialogName) + GoTo Finally +End Function ' SFDialogs.SF_Register._NewDialog + +REM ============================================== END OF SFDIALOGS.SF_REGISTER + \ No newline at end of file diff --git a/wizards/source/sfdialogs/__License.xba b/wizards/source/sfdialogs/__License.xba new file mode 100644 index 000000000..e98be710e --- /dev/null +++ b/wizards/source/sfdialogs/__License.xba @@ -0,0 +1,26 @@ + + + +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDialogs library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/sfdialogs/dialog.xlb b/wizards/source/sfdialogs/dialog.xlb new file mode 100644 index 000000000..be8e58d45 --- /dev/null +++ b/wizards/source/sfdialogs/dialog.xlb @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/wizards/source/sfdialogs/script.xlb b/wizards/source/sfdialogs/script.xlb new file mode 100644 index 000000000..6dff54d87 --- /dev/null +++ b/wizards/source/sfdialogs/script.xlb @@ -0,0 +1,9 @@ + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Base.xba b/wizards/source/sfdocuments/SF_Base.xba new file mode 100644 index 000000000..1e6395dbf --- /dev/null +++ b/wizards/source/sfdocuments/SF_Base.xba @@ -0,0 +1,993 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Base +''' ======= +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' the management and several manipulations of LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the SF_Document module. +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Writer, ... +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties. +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The SF_Base module is provided mainly to block parent properties that are NOT applicable to Base documents +''' In addition, it provides methods to identify form documents and access their internal forms +''' (read more elsewhere (the "SFDocuments.Form" service) about this subject) +''' +''' The current module is closely related to the "UI" service of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.CreateBaseDocument("C:\Me\MyFile.odb", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.odb") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Base", "MyFile.odb") +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_base.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DBCONNECTERROR = "DBCONNECTERROR" +Private Const FORMDEADERROR = "FORMDEADERROR" +Private Const BASEFORMNOTFOUNDERROR = "BASEFORMNOTFOUNDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private [_Super] As Object ' Document superclass, which the current instance is a subclass of +Private ObjectType As String ' Must be BASE +Private ServiceName As String + +' UNO references +Private _Component As Object ' com.sun.star.comp.dba.ODatabaseDocument +Private _DataSource As Object ' com.sun.star.comp.dba.ODatabaseSource +Private _Database As Object ' SFDatabases.Database service instance +Private _FormDocuments As Object + +REM ============================================================ MODULE CONSTANTS + +Const ISBASEFORM = 3 ' Form is stored in a Base document +Const cstToken = "//" ' Form names accept special characters but not slashes + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + Set [_Super] = Nothing + ObjectType = "BASE" + ServiceName = "SFDocuments.Base" + Set _Component = Nothing + Set _DataSource = Nothing + Set _Database = Nothing + Set _FormDocuments = Nothing +End Sub ' SFDocuments.SF_Base Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Base Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Base Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean +''' The closure of a Base document requires the closures of +''' 1) the connection => done in the CloseDatabase() method +''' 2) the data source +''' 3) the document itself => done in the superclass + +Const cstThisSub = "SFDocuments.Base.CloseDocument" +Const cstSubArgs = "[SaveAsk=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(SaveAsk) Or IsEmpty(SaveAsk) Then SaveAsk = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SaveAsk, "SaveAsk", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + If Not IsNull(_Database) Then _Database.CloseDatabase() + If Not IsNull(_DataSource) Then _DataSource.dispose() + CloseDocument = [_Super].CloseDocument(SaveAsk) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CloseFormDocument(Optional ByVal FormDocument As Variant) As Boolean +''' Close the given form document +''' Nothing happens if the form document is not open +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Returns: +''' True if closure is successful +''' Example: +''' oDoc.CloseFormDocument("Folder1/myFormDocument") + +Dim bClose As Boolean ' Return value +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Dim vFormNames As Variant ' Array of all document form names present in the document + +Const cstThisSub = "SFDocuments.Base.CloseFormDocument" +Const cstSubArgs = "FormDocument" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo Finally + +Try: + Set oMainForm = _FormDocuments.getByHierarchicalName(FormDocument) + bClose = oMainForm.close() + +Finally: + CloseFormDocument = bClose + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.CloseFormDocument + +REM ----------------------------------------------------------------------------- +Public Function FormDocuments() As Variant +''' Return the list of the FormDocuments contained in the Base document +''' Args: +''' Returns: +''' A zero-base array of strings +''' Each entry is the full path name of a form document. The path separator is the slash ("/") +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.FormDocuments() + +Dim vFormNames As Variant ' Array of all form names present in the document +Const cstThisSub = "SFDocuments.Base.FormDocuments" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If + +Try: + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + +Finally: + FormDocuments = vFormNames + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.FormDocuments + +REM ----------------------------------------------------------------------------- +Public Function Forms(Optional ByVal FormDocument As Variant _ + , Optional ByVal Form As Variant _ + ) As Variant +''' Return either +''' - the list of the Forms contained in the form document +''' - a SFDocuments.Form object based on its name or its index +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Form: a form stored in the Base document given by its name or its index +''' When absent, the list of available forms is returned +''' To get the first (unique ?) form stored in the form document, set Form = 0 +''' Returns: +''' A zero-based array of strings if Form is absent +''' An instance of the SF_Form class if Form exists +''' Exceptions: +''' FORMDEADERROR The form is not open +''' BASEFORMNOTFOUNDERROR FormDocument OK but Form not found +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.Forms("Folder1/myFormDocument") +''' Set myForm = oDoc.Forms("Folder1/myFormDocument", 0) + +Dim oForm As Object ' The new Form class instance +Dim oFormDocument As Object ' com.sun.star.comp.sdb.Content +Dim oXForm As Object ' com.sun.star.form.XForm +Dim vFormDocuments As Variant ' Array of form documents +Dim vFormNames As Variant ' Array of form names +Dim oForms As Object ' Forms collection +Const cstDrawPage = 0 ' Only 1 drawpage in a Base document + +Const cstThisSub = "SFDocuments.Base.Forms" +Const cstSubArgs = "FormDocument, [Form=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Form) Or IsEmpty(Form) Then Form = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormDocuments = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormDocuments) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo CatchClosed + +Try: + ' Start from the form document and go down to forms + Set oFormDocument = _FormDocuments.getByHierarchicalName(FormDocument) + Set oForms = oFormDocument.Component.DrawPages(cstDrawPage).Forms + vFormNames = oForms.getElementNames() + + If Len(Form) = 0 Then ' Return the list of valid form names + Forms = vFormNames + Else + If VarType(Form) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Utils._Validate(Form, "Form", V_STRING, vFormNames) Then GoTo Finally + Set oXForm = oForms.getByName(Form) + Else ' Find the form by index + If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound + Set oXForm = oForms.getByIndex(Form) + End If + ' Create the new Form class instance + Set oForm = New SF_Form + With oForm + ._Name = oXForm.Name + Set .[Me] = oForm + Set .[_Parent] = [Me] + Set ._Component = _Component + ._FormDocumentName = FormDocument + Set ._FormDocument = oFormDocument + ._FormType = ISBASEFORM + Set ._Form = oXForm + ._Initialize() + End With + Set Forms = oForm + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchClosed: + ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, FormDocument, _FileIdent()) +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(BASEFORMNOTFOUNDERROR, Form, FormDocument, _FileIdent()) +End Function ' SFDocuments.SF_Base.Forms + +REM ----------------------------------------------------------------------------- +Public Function GetDatabase(Optional ByVal User As Variant _ + , Optional ByVal Password As Variant _ + ) As Object +''' Returns a Database instance (service = SFDatabases.Database) giving access +''' to the execution of SQL commands on the database defined and/or stored in +''' the actual Base document +''' Args: +''' User, Password: the login parameters as strings. Defaults = "" +''' Returns: +''' A SFDatabases.Database instance or Nothing +''' Example: +''' Dim myDb As Object +''' Set myDb = oDoc.GetDatabase() + +Const cstThisSub = "SFDocuments.Base.GetDatabase" +Const cstSubArgs = "[User=""""], [Password=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set GetDatabase = Nothing + +Check: + If IsMissing(User) Or IsEmpty(User) Then User = "" + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(User, "User", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + End If + +Try: + If IsNull(_Database) Then ' 1st connection from the current document instance + If IsNull(_DataSource) Then GoTo CatchConnect + Set _Database = ScriptForge.SF_Services.CreateScriptService("SFDatabases.DatabaseFromDocument" _ + , _DataSource, User, Password) + If IsNull(_Database) Then GoTo CatchConnect + _Database._Location = [_Super]._WindowFileName + EndIf + +Finally: + Set GetDatabase = _Database + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchConnect: + ScriptForge.SF_Exception.RaiseFatal(DBCONNECTERROR, "User", User, "Password", Password, [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Base.GetDatabase + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Base.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + ' Superclass or subclass property ? + If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then + GetProperty = [_Super].GetProperty(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function IsLoaded(Optional ByVal FormDocument As Variant) As Boolean +''' Return True if the given FormDocument is open for the user +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Returns: +''' True if the form document is currently open, otherwise False +''' Exceptions: +''' Form name is invalid +''' Example: +''' MsgBox oDoc.IsLoaded("Folder1/myFormDocument") + +Dim bLoaded As Boolean ' Return value +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Const cstThisSub = "SFDocuments.Base.IsLoaded" +Const cstSubArgs = "FormDocument" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bLoaded = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + End If + +Try: + Set oMainForm = _FormDocuments.getByHierarchicalName(FormDocument) + ' A document form that has never been opened has no component + ' If ever opened and closed afterwards, it keeps the Component but loses its Controller + bLoaded = Not IsNull(oMainForm.Component) + If bLoaded Then bLoaded = Not IsNull(oMainForm.Component.CurrentController) + +Finally: + IsLoaded = bLoaded + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.IsLoaded + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Base class as an array + + Methods = Array( _ + "CloseFormDocument" _ + , "FormDocuments" _ + , "Forms" _ + , "GetDatabase" _ + , "IsLoaded" _ + , "OpenFormDocument" _ + , "PrintOut" _ + , "SetPrinter" _ + ) + +End Function ' SFDocuments.SF_Base.Methods + +REM ----------------------------------------------------------------------------- +Public Function OpenFormDocument(Optional ByVal FormDocument As Variant _ + , Optional ByVal DesignMode As Variant _ + ) As Boolean +''' Open the FormDocument given by its hierarchical name either in normal or in design mode +''' If the form document is already open, the form document is made active without changing its mode +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' DesignMode: when True the form document is opened in design mode (Default = False) +''' Returns: +''' True if the form document could be opened, otherwise False +''' Exceptions: +''' Form name is invalid +''' Example: +''' oDoc.OpenFormDocument("Folder1/myFormDocument") + +Dim bOpen As Boolean ' Return value +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim oContainer As Object ' com.sun.star.awt.XWindow +Dim oNewForm As Object ' Output of loadComponent() +Const cstThisSub = "SFDocuments.Base.OpenFormDocument" +Const cstSubArgs = "FormDocument, [DesignMode=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bOpen = False + +Check: + If IsMissing(DesignMode) Or IsEmpty(DesignMode) Then DesignMode = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DesignMode, "DesignMode", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + With _Component.CurrentController + If Not .IsConnected Then .connect() + ' loadComponent activates the form when already loaded + Set oNewForm = .loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, FormDocument, DesignMode) + ' When user opened manually the form in design mode and closed it, the next execution in normal mode needs to be confirmed as below + With oNewForm.CurrentController + If .isFormDesignMode() <> DesignMode Then .setFormDesignMode(DesignMode) + End With + End With + bOpen = True + +Finally: + OpenFormDocument = bOpen + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.OpenFormDocument + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal FormDocument As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + ) As Boolean +''' Send the content of the given form document to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' The given form document must be open. It is activated by the method. +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' Exceptions: +''' FORMDEADERROR The form is not open +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("myForm", "1-4;10;15-18", Copies := 2) + +Dim bPrint As Boolean ' Return value +Dim vFormNames As Variant ' Array of all document form names present in the document +Dim oFormDocument As Object ' com.sun.star.comp.sdb.Content + +Const cstThisSub = "SFDocuments.Base.PrintOut" +Const cstSubArgs = "FormDocument, [Pages=""""], [Copies=1]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormNames = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormNames) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo CatchClosed + +Try: + Set oFormDocument = _FormDocuments.getByHierarchicalName(FormDocument) + bPrint = [_Super].PrintOut(Pages, Copies, oFormDocument.Component) + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchClosed: + ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, FormDocument, _FileIdent()) +End Function ' SFDocuments.SF_Base.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Base class as an array + + Properties = Array( _ + "DocumentType" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw " _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "XComponent" _ + ) + +End Function ' SFDocuments.SF_Base.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal FormDocument As Variant _ + , Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + ) As Boolean +''' Define the printer options for a form document. The form document must be open. +''' Args: +''' FormDocument: a valid document form name as a case-sensitive string +''' Printer: the name of the printer queue where to print to +''' When absent or space, the default printer is set +''' Orientation: either "PORTRAIT" or "LANDSCAPE". Left unchanged when absent +''' PaperFormat: one of next values +''' "A3", "A4", "A5", "B4", "B5", "LETTER", "LEGAL", "TABLOID" +''' Left unchanged when absent +''' Returns: +''' True when successful +''' Examples: +''' oDoc.SetPrinter("myForm", Orientation := "PORTRAIT") + +Dim bPrinter As Boolean ' Return value +Dim vFormDocuments As Variant ' Array of form documents +Dim oFormDocument As Object ' com.sun.star.comp.sdb.Content + +Const cstThisSub = "SFDocuments.Base.SetPrinter" +Const cstSubArgs = "FormDocument, [Printer=""""], [Orientation=""PORTRAIT""|""LANDSCAPE""]" _ + & ", [PaperFormat=""A3""|""A4""|""A5""|""B4""|""B5""|""LETTER""|""LEGAL""|""TABLOID""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrinter = False + +Check: + If IsMissing(Printer) Or IsEmpty(Printer) Then Printer = "" + If IsMissing(Orientation) Or IsEmpty(Orientation) Then Orientation = "" + If IsMissing(PaperFormat) Or IsEmpty(PaperFormat) Then PaperFormat = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + ' Build list of available FormDocuments recursively with _CollectFormDocuments + If IsNull(_FormDocuments) Then Set _FormDocuments = _Component.getFormDocuments() + vFormDocuments = Split(_CollectFormDocuments(_FormDocuments), cstToken) + If Not ScriptForge.SF_Utils._Validate(FormDocument, "FormDocument", V_STRING, vFormDocuments) Then GoTo Finally + End If + If Not IsLoaded(FormDocument) Then GoTo CatchClosed + +Try: + Set oFormDocument = _FormDocuments.getByHierarchicalName(FormDocument) + bPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat, oFormDocument.Component) + +Finally: + SetPrinter = bPrinter + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchClosed: + ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, FormDocument, _FileIdent()) +End Function ' SFDocuments.SF_Base.SetPrinter + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Base.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + Select Case UCase(PropertyName) + Case Else + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Base.SetProperty + +REM ======================================================= SUPERCLASS PROPERTIES + +REM ----------------------------------------------------------------------------- +'Property Get CustomProperties() As Variant +' CustomProperties = [_Super].GetProperty("CustomProperties") +'End Property ' SFDocuments.SF_Base.CustomProperties + +REM ----------------------------------------------------------------------------- +'Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) +' [_Super].CustomProperties = pvCustomProperties +'End Property ' SFDocuments.SF_Base.CustomProperties + +REM ----------------------------------------------------------------------------- +'Property Get Description() As Variant +' Description = [_Super].GetProperty("Description") +'End Property ' SFDocuments.SF_Base.Description + +REM ----------------------------------------------------------------------------- +'Property Let Description(Optional ByVal pvDescription As Variant) +' [_Super].Description = pvDescription +'End Property ' SFDocuments.SF_Base.Description + +REM ----------------------------------------------------------------------------- +'Property Get DocumentProperties() As Variant +' DocumentProperties = [_Super].GetProperty("DocumentProperties") +'End Property ' SFDocuments.SF_Base.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String + DocumentType = [_Super].GetProperty("DocumentType") +End Property ' SFDocuments.SF_Base.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = [_Super].GetProperty("IsBase") +End Property ' SFDocuments.SF_Base.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = [_Super].GetProperty("IsCalc") +End Property ' SFDocuments.SF_Base.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = [_Super].GetProperty("IsDraw") +End Property ' SFDocuments.SF_Base.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = [_Super].GetProperty("IsImpress") +End Property ' SFDocuments.SF_Base.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = [_Super].GetProperty("IsMath") +End Property ' SFDocuments.SF_Base.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = [_Super].GetProperty("IsWriter") +End Property ' SFDocuments.SF_Base.IsWriter + +REM ----------------------------------------------------------------------------- +'Property Get Keywords() As Variant +' Keywords = [_Super].GetProperty("Keywords") +'End Property ' SFDocuments.SF_Base.Keywords + +REM ----------------------------------------------------------------------------- +'Property Let Keywords(Optional ByVal pvKeywords As Variant) +' [_Super].Keywords = pvKeywords +'End Property ' SFDocuments.SF_Base.Keywords + +REM ----------------------------------------------------------------------------- +'Property Get Readonly() As Variant +' Readonly = [_Super].GetProperty("Readonly") +'End Property ' SFDocuments.SF_Base.Readonly + +REM ----------------------------------------------------------------------------- +'Property Get Subject() As Variant +' Subject = [_Super].GetProperty("Subject") +'End Property ' SFDocuments.SF_Base.Subject + +REM ----------------------------------------------------------------------------- +'Property Let Subject(Optional ByVal pvSubject As Variant) +' [_Super].Subject = pvSubject +'End Property ' SFDocuments.SF_Base.Subject + +REM ----------------------------------------------------------------------------- +'Property Get Title() As Variant +' Title = [_Super].GetProperty("Title") +'End Property ' SFDocuments.SF_Base.Title + +REM ----------------------------------------------------------------------------- +'Property Let Title(Optional ByVal pvTitle As Variant) +' [_Super].Title = pvTitle +'End Property ' SFDocuments.SF_Base.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant + XComponent = [_Super].GetProperty("XComponent") +End Property ' SFDocuments.SF_Base.XComponent + +REM ========================================================== SUPERCLASS METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean + Activate = [_Super].Activate() +End Function ' SFDocuments.SF_Base.Activate + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object + Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) +End Function ' SFDocuments.SF_Base.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean + RemoveMenu = [_Super].RemoveMenu(MenuHeader) +End Function ' SFDocuments.SF_Base.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) + [_Super].RunCommand(Command, Args) +End Sub ' SFDocuments.SF_Base.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean + Save = [_Super].Save() +End Function ' SFDocuments.SF_Base.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Base.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Base.SaveCopyAs + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _CollectFormDocuments(ByRef poContainer As Object) As String +''' Returns a token-separated string of all hierarchical formdocument names +''' depending on the formdocuments container in argument +''' The function traverses recursively the whole tree below the container +''' The initial call starts from the container _Component.getFormDocuments +''' The list contains closed and open forms + +Dim sCollectNames As String ' Return value +Dim oSubItem As Object ' com.sun.star.container.XNameAccess (folder) or com.sun.star.ucb.XContent (form) +Dim i As Long +Const cstFormType = "application/vnd.oasis.opendocument.text" + ' Identifies forms. Folders have a zero-length content type + + On Local Error GoTo Finally + +Try: + sCollectNames = "" + With poContainer + For i = 0 To .Count - 1 + Set oSubItem = .getByIndex(i) + If oSubItem.ContentType = cstFormType Then ' Add the form to the list + sCollectNames = sCollectNames & cstToken & oSubItem.HierarchicalName + Else + sCollectNames = sCollectNames & cstToken & _CollectFormDocuments(oSubItem) + End If + Next i + End With + +Finally: + _CollectFormDocuments = Mid(sCollectNames, Len(cstToken) + 1) ' Skip the initial token + Exit Function +End Function ' SFDocuments.SF_Base._CollectFormDocuments + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Base._FileIdent + +REM ----------------------------------------------------------------------------- +Private Function _FindByPersistentName(ByRef poContainer As Object _ + , psPersistent As String _ + ) As Object +''' The FormDocuments property of a Base component has strangely +''' a getByHierarchical() method but no access to the same com.sun.star.comp.sdb.Content +''' object via its persistent/ODF name +''' This method returns the object having the given persistent name +''' The function traverses recursively the whole tree below the container until found +''' The initial call starts from the container _Component.getFormDocuments +''' The list contains closed and open forms +''' Args: +''' poContainer: the actual top of the free, initially _FormDocuments +''' psPersistent: a name like "Obj..." +''' Returns: +''' A com.sun.star.comp.sdb.Content object (object found, the process stops) +''' or Nothing (object not found, the process continues) + +Dim oMainForm As Object ' Return value +Dim oSubItem As Object ' com.sun.star.container.XNameAccess (folder) or com.sun.star.ucb.XContent (form) +Dim i As Long +Const cstFormType = "application/vnd.oasis.opendocument.text" + ' Identifies forms. Folders have a zero-length content type + + On Local Error GoTo Finally + +Try: + Set oMainForm = Nothing + With poContainer + For i = 0 To .Count - 1 + Set oSubItem = .getByIndex(i) + If oSubItem.ContentType = cstFormType Then ' Examine its persistent name + If oSubItem.PersistentName = psPersistent Then + Set oMainForm = oSubItem + Exit For + End If + Else + Set oMainForm = _FindByPersistentName(oSubItem, psPersistent) + End If + Next i + End With + +Finally: + Set _FindByPersistentName = oMainForm + Exit Function +End Function ' SFDocuments.SF_Base.FindByPersistentName + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) + +Finally: + _IsStillAlive = bAlive + Exit Function +End Function ' SFDocuments.SF_Base._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvArg As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim oProperties As Object ' Document or Custom properties +Dim vLastCell As Variant ' Coordinates of last used cell in a sheet +Dim oSelect As Object ' Current selection +Dim vRanges As Variant ' List of selected ranges +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + cstThisSub = "SFDocuments.SF_Base.get" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case psProperty + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Base._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Base instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Base]: Type/File" + + _Repr = "[Base]: " & [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Base._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_BASE + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Calc.xba b/wizards/source/sfdocuments/SF_Calc.xba new file mode 100644 index 000000000..0b7b88ae8 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Calc.xba @@ -0,0 +1,4501 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Calc +''' ======= +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' managing and manipulating LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the SF_Document module. +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ... +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties. +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The SF_Calc module is focused on : +''' - management (copy, insert, move, ...) of sheets within a Calc document +''' - exchange of data between Basic data structures and Calc ranges of values +''' +''' The current module is closely related to the "UI" service of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.CreateDocument("Calc", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.ods") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Default = ActiveWindow +''' ' or Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Untitled 1 is presumed a Calc document +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Definitions: +''' Many methods require a "Sheet" or a "Range" as argument. (NB: a single cell is considered as a special case of a Range) +''' Usually, within a specific Calc instance, sheets and ranges are given as a string: "SheetX" and "D2:F6" +''' Multiple ranges are not supported in this context. +''' Additionally, the .Sheet and .Range methods return a reference that may be used +''' as argument of a method called from another instance of the Calc service +''' Example: +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\FileB.ods") +''' oDocB.CopyToRange(oDocA.Range("SheetX.D4:F8"), "D2:F6") ' CopyToRange(source, target) +''' +''' Sheet: the sheet name as a string or an object produced by .Sheet() +''' "~" = current sheet +''' Range: a string designating a set of contiguous cells located in a sheet of the current instance +''' "~" = current selection (if multiple selections, its 1st component) +''' or an object produced by .Range() +''' The sheet name is optional (default = active sheet). Surrounding quotes and $ signs are optional +''' ~.~, ~ The current selection in the active sheet +''' '$SheetX'.D2 or $D$2 A single cell +''' '$SheetX'.D2:F6, D2:D10 Multiple cells +''' '$SheetX'.A:A or 3:5 All cells in the same column or row up to the last active cell +''' SheetX.* All cells up to the last active cell +''' myRange A range name at spreadsheet level +''' ~.yourRange, SheetX.someRange A range name at sheet level +''' myDoc.Range("SheetX.D2:F6") +''' A range within the sheet SheetX in file associated with the myDoc Calc instance +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_calc.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR" +Private Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR" +Private Const CALCADDRESSERROR = "CALCADDRESSERROR" +Private Const DUPLICATESHEETERROR = "DUPLICATESHEETERROR" +Private Const OFFSETADDRESSERROR = "OFFSETADDRESSERROR" +Private Const CALCFORMNOTFOUNDERROR = "CALCFORMNOTFOUNDERROR" +Private Const DUPLICATECHARTERROR = "DUPLICATECHARTERROR" +Private Const RANGEEXPORTERROR = "RANGEEXPORTERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Super] As Object ' Document superclass, which the current instance is a subclass of +Private ObjectType As String ' Must be CALC +Private ServiceName As String + +' Window component +Private _Component As Object ' com.sun.star.lang.XComponent + +Type _Address + ObjectType As String ' Must be "SF_CalcReference" + ServiceName As String ' Must be "SFDocuments.CalcReference" + RawAddress As String + Component As Object ' com.sun.star.lang.XComponent + SheetName As String + SheetIndex As Integer + RangeName As String + Height As Long + Width As Long + XSpreadSheet As Object ' com.sun.star.sheet.XSpreadsheet + XCellRange As Object ' com.sun.star.table.XCellRange +End Type + +Private _LastParsedAddress As Object ' _Address type - parsed ranges are cached + +REM ============================================================ MODULE CONSTANTS + +Private Const cstSHEET = 1 +Private Const cstRANGE = 2 + +Private Const MAXCOLS = 2^10 ' Max number of columns in a sheet +Private Const MAXROWS = 2^20 ' Max number of rows in a sheet + +Private Const CALCREFERENCE = "SF_CalcReference" ' Object type of _Address +Private Const SERVICEREFERENCE = "SFDocuments.CalcReference" + ' Service name of _Address (used in Python) + +Private Const ISCALCFORM = 2 ' Form is stored in a Calc document + +Private Const cstSPECIALCHARS = " `~!@#$%^&()-_=+{}|;:,<.>""" + ' Presence of a special character forces surrounding the sheet name with single quotes in absolute addresses + + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Super] = Nothing + ObjectType = "CALC" + ServiceName = "SFDocuments.Calc" + Set _Component = Nothing + Set _LastParsedAddress = Nothing +End Sub ' SFDocuments.SF_Calc Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Calc Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Calc Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CurrentSelection() As Variant +''' Returns as a string the currently selected range or as an array the list of the currently selected ranges + CurrentSelection = _PropertyGet("CurrentSelection") +End Property ' SFDocuments.SF_Calc.CurrentSelection (get) + +REM ----------------------------------------------------------------------------- +Property Let CurrentSelection(Optional ByVal pvSelection As Variant) +''' Set the selection to a single or a multiple range +''' The argument is a string or an array of strings + +Dim sRange As String ' A single selection +Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges +Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress +Dim i As Long +Const cstThisSub = "SFDocuments.Calc.setCurrentSelection" +Const cstSubArgs = "Selection" + + On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If IsArray(pvSelection) Then + If Not ScriptForge.SF_Utils._ValidateArray(pvSelection, "pvSelection", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(pvSelection, "pvSelection", V_STRING) Then GoTo Finally + End If + End If + +Try: + If IsArray(pvSelection) Then + Set oCellRanges = _Component.createInstance("com.sun.star.sheet.SheetCellRanges") + vRangeAddresses = Array() + ReDim vRangeAddresses(0 To UBound(pvSelection)) + For i = 0 To UBound(pvSelection) + vRangeAddresses(i) = Range(pvSelection(i)).XCellRange.RangeAddress + Next i + oCellRanges.addRangeAddresses(vRangeAddresses, False) + _Component.CurrentController.select(oCellRanges) + Else + _Component.CurrentController.select(_ParseAddress(pvSelection).XCellRange) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +Catch: + GoTo Finally +End Property ' SFDocuments.SF_Calc.CurrentSelection (let) + +REM ----------------------------------------------------------------------------- +Property Get FirstCell(Optional ByVal RangeName As Variant) As String +''' Returns the First used cell in a given range or sheet +''' When the argument is a sheet it will always return the "sheet.$A$1" cell + FirstCell = _PropertyGet("FirstCell", RangeName) +End Property ' SFDocuments.SF_Calc.FirstCell + +REM ----------------------------------------------------------------------------- +Property Get FirstColumn(Optional ByVal RangeName As Variant) As Long +''' Returns the leftmost column in a given sheet or range +''' When the argument is a sheet it will always return 1 + FirstColumn = _PropertyGet("FirstColumn", RangeName) +End Property ' SFDocuments.SF_Calc.FirstColumn + +REM ----------------------------------------------------------------------------- +Property Get FirstRow(Optional ByVal RangeName As Variant) As Long +''' Returns the First used column in a given range +''' When the argument is a sheet it will always return 1 + FirstRow = _PropertyGet("FirstRow", RangeName) +End Property ' SFDocuments.SF_Calc.FirstRow + +REM ----------------------------------------------------------------------------- +Property Get Height(Optional ByVal RangeName As Variant) As Long +''' Returns the height in # of rows of the given range + Height = _PropertyGet("Height", RangeName) +End Property ' SFDocuments.SF_Calc.Height + +REM ----------------------------------------------------------------------------- +Property Get LastCell(Optional ByVal RangeName As Variant) As String +''' Returns the last used cell in a given sheet or range + LastCell = _PropertyGet("LastCell", RangeName) +End Property ' SFDocuments.SF_Calc.LastCell + +REM ----------------------------------------------------------------------------- +Property Get LastColumn(Optional ByVal RangeName As Variant) As Long +''' Returns the last used column in a given sheet + LastColumn = _PropertyGet("LastColumn", RangeName) +End Property ' SFDocuments.SF_Calc.LastColumn + +REM ----------------------------------------------------------------------------- +Property Get LastRow(Optional ByVal RangeName As Variant) As Long +''' Returns the last used column in a given sheet + LastRow = _PropertyGet("LastRow", RangeName) +End Property ' SFDocuments.SF_Calc.LastRow + +REM ----------------------------------------------------------------------------- +Property Get Range(Optional ByVal RangeName As Variant) As Variant +''' Returns a (internal) range object + Range = _PropertyGet("Range", RangeName) +End Property ' SFDocuments.SF_Calc.Range + +REM ----------------------------------------------------------------------------- +Property Get Region(Optional ByVal RangeName As Variant) As String +''' Returns the smallest area as a range string that contains the given range +''' and which is completely surrounded with empty cells + Region = _PropertyGet("Region", RangeName) +End Property ' SFDocuments.SF_Calc.Region + +REM ----------------------------------------------------------------------------- +Property Get Sheet(Optional ByVal SheetName As Variant) As Variant +''' Returns a (internal) sheet object + Sheet = _PropertyGet("Sheet", SheetName) +End Property ' SFDocuments.SF_Calc.Sheet + +REM ----------------------------------------------------------------------------- +Property Get SheetName(Optional ByVal RangeName As Variant) As String +''' Returns the sheet name part of a range + SheetName = _PropertyGet("SheetName", RangeName) +End Property ' SFDocuments.SF_Calc.SheetName + +REM ----------------------------------------------------------------------------- +Property Get Sheets() As Variant +''' Returns an array listing the existing sheet names + Sheets = _PropertyGet("Sheets") +End Property ' SFDocuments.SF_Calc.Sheets + +REM ----------------------------------------------------------------------------- +Property Get Width(Optional ByVal RangeName As Variant) As Long +''' Returns the width in # of columns of the given range + Width = _PropertyGet("Width", RangeName) +End Property ' SFDocuments.SF_Calc.Width + +REM ----------------------------------------------------------------------------- +Property Get XCellRange(Optional ByVal RangeName As Variant) As Variant +''' Returns a UNO object of type com.sun.star.Table.CellRange + XCellRange = _PropertyGet("XCellRange", RangeName) +End Property ' SFDocuments.SF_Calc.XCellRange + +REM ----------------------------------------------------------------------------- +Property Get XSheetCellCursor(Optional ByVal RangeName As Variant) As Variant +''' Returns a UNO object of type com.sun.star.sheet.XSheetCellCursor +'' After having moved the cursor (gotoNext(), ...) the resulting range can be got +''' back as a string with the cursor.AbsoluteName UNO property. + XSheetCellCursor = _PropertyGet("XSheetCellCursor", RangeName) +End Property ' SFDocuments.SF_Calc.XSheetCellCursor + +REM ----------------------------------------------------------------------------- +Property Get XSpreadsheet(Optional ByVal SheetName As Variant) As Variant +''' Returns a UNO object of type com.sun.star.sheet.XSpreadsheet + XSpreadsheet = _PropertyGet("XSpreadsheet", SheetName) +End Property ' SFDocuments.SF_Calc.XSpreadsheet + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function A1Style(Optional ByVal Row1 As Variant _ + , Optional ByVal Column1 As Variant _ + , Optional ByVal Row2 As Variant _ + , Optional ByVal Column2 As Variant _ + , Optional ByVal SheetName As Variant _ + ) As String +''' Returns a range expressed in A1-style as defined by its coordinates +''' If only one pair of coordinates is given, the range will embrace only a single cell +''' Args: +''' Row1 : the row number of the first coordinate +''' Column1 : the column number of the first coordinates +''' Row2 : the row number of the second coordinate +''' Column2 : the column number of the second coordinates +''' SheetName: Default = the current sheet. If present, the sheet must exist. +''' Returns: +''' A range as a string +''' Exceptions: +''' Examples: +''' range = oDoc.A1Style(5, 2, 10, 4, "SheetX") ' "'$SheetX'.$E$2:$J$4" + +Dim sA1Style As String ' Return value +Dim vSheetName As Variant ' Alias of SheetName - necessary see [Bug 145279] +Dim lTemp As Long ' To switch 2 values +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.A1Style" +Const cstSubArgs = "Row1, Column1, [Row2], [Column2], [SheetName]=""""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sA1Style = "" + +Check: + If IsMissing(Row2) Or IsEmpty(Row2) Then Row2 = 0 + If IsMissing(Column2) Or IsEmpty(Column2) Then Column2 = 0 + If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "~" + vSheetName = SheetName + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Row1, "Row1", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Column1, "Column1", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Row2, "Row2", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Column2, "Column2", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not _ValidateSheet(vSheetName, "SheetName", , True, True, , , True) Then GoTo Finally + End If + + If Row1 > MAXROWS Then Row1 = MAXROWS + If Row2 > MAXROWS Then Row2 = MAXROWS + If Column1 > MAXCOLS Then Column1 = MAXCOLS + If Column2 > MAXCOLS Then Column2 = MAXCOLS + + If Row2 > 0 And Row2 < Row1 Then + lTemp = Row2 : Row2 = Row1 : Row1 = lTemp + End If + If Column2 > 0 And Column2 < Column1 Then + lTemp = Column2 : Column2 = Column1 : Column1 = lTemp + End If + +Try: + ' Surround the sheet name with single quotes when required by the presence of special characters + vSheetName = _QuoteSheetName(vSheetName) + ' Define the new range string + sA1Style = "$" & vSheetName & "." _ + & "$" & _GetColumnName(Column1) & "$" & CLng(Row1) _ + & Iif(Row2 > 0 And Column2 > 0, ":$" & _GetColumnName(Column2) & "$" & CLng(Row2), "") + +Finally: + A1Style = sA1Style + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.A1Style + +REM ----------------------------------------------------------------------------- +Public Function Activate(Optional ByVal SheetName As Variant) As Boolean +''' Make the current document or the given sheet active +''' Args: +''' SheetName: Default = the Calc document as a whole +''' Returns: +''' True if the document or the sheet could be made active +''' Otherwise, there is no change in the actual user interface +''' Examples: +''' oDoc.Activate("SheetX") + +Dim bActive As Boolean ' Return value +Dim oSheet As Object ' Reference to sheet +Const cstThisSub = "SFDocuments.Calc.Activate" +Const cstSubArgs = "[SheetName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActive = False + +Check: + If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , , True) Then GoTo Finally + End If + +Try: + ' Sheet activation, to do only when meaningful, precedes document activation + If Len(SheetName) > 0 Then + With _Component + Set oSheet = .getSheets.getByName(SheetName) + Set .CurrentController.ActiveSheet = oSheet + End With + End If + bActive = [_Super].Activate() + +Finally: + Activate = bActive + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.Activate + +REM ----------------------------------------------------------------------------- +Public Function Charts(Optional ByVal SheetName As Variant _ + , Optional ByVal ChartName As Variant _ + ) As Variant +''' Return either the list of charts present in the given sheet or a chart object +''' Args: +''' SheetName: The name of an existing sheet +''' ChartName: The user-defined name of the targeted chart or the zero-length string +''' Returns: +''' When ChartName = "", return the list of the charts present in the sheet, +''' otherwise, return a new chart service instance +''' Examples: +''' Dim oChart As Object +''' Set oChart = oDoc.Charts("SheetX", "myChart") + +Dim vCharts As Variant ' Return value when array of chart names +Dim oChart As Object ' Return value when new chart instance +Dim oSheet As Object ' Alias of SheetName as reference +Dim oDrawPage As Object ' com.sun.star.drawing.XDrawPage +Dim oNextShape As Object ' com.sun.star.drawing.XShape +Dim sChartName As String ' Some chart name +Dim lCount As Long ' Counter for charts among all drawing objects +Dim i As Long +Const cstChartShape = "com.sun.star.drawing.OLE2Shape" + +Const cstThisSub = "SFDocuments.Calc.Charts" +Const cstSubArgs = "SheetName, [ChartName=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vCharts = Array() + +Check: + If IsMissing(ChartName) Or IsEmpty(ChartName) Then ChartName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally + End If + +Try: + ' Because the user can change it constantly, the list of valid charts has to be rebuilt at each time + ' Explore charts starting from the draw page + Set oSheet = _Component.getSheets.getByName(SheetName) + Set oDrawPage = oSheet.getDrawPage() + vCharts = Array() + Set oChart = Nothing + lCount = -1 + For i = 0 To oDrawPage.Count - 1 + Set oNextShape = oDrawPage.getByIndex(i) + if oNextShape.supportsService(cstChartShape) Then ' Ignore other shapes + sChartName = oNextShape.Name ' User-defined name + If Len(sChartName) = 0 Then sChartName = oNextShape.PersistName ' Internal name + ' Is chart found ? + If Len(ChartName) > 0 Then + If ChartName = sChartName Then + Set oChart = New SF_Chart + With oChart + Set .[Me] = oChart + Set .[_Parent] = [Me] + ._SheetName = SheetName + ._DrawIndex = i + ._ChartName = ChartName + ._PersistentName = oNextShape.PersistName + Set ._Shape = oNextShape + Set ._Chart = oSheet.getCharts().getByName(._PersistentName) + Set ._ChartObject = ._Chart.EmbeddedObject + Set ._Diagram = ._ChartObject.Diagram + End With + Exit For + End If + End If + ' Build stack of chart names + lCount = lCount + 1 + If UBound(vCharts) < 0 Then + vCharts = Array(sChartName) + Else + ReDim Preserve vCharts(0 To UBound(vCharts) + 1) + vCharts(lCount) = sChartName + End If + End If + Next i + + ' Raise error when chart not found + If Len(ChartName) > 0 And IsNull(oChart) Then + If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING, vCharts) Then GoTo Finally + End If + +Finally: + If Len(ChartName) = 0 Then Charts = vCharts Else Set Charts = oChart + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.Charts + +REM ----------------------------------------------------------------------------- +Public Sub ClearAll(Optional ByVal Range As Variant) As String +''' Clear entirely the given range +''' Args: +''' Range : the cell or the range as a string that should be cleared +''' Examples: +''' oDoc.ClearAll("SheetX") ' Clears the used area of the sheet + +Dim lClear As Long ' The elements to clear +Dim oRange As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.ClearAll" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + With com.sun.star.sheet.CellFlags + lClear = 0 _ + + .VALUE _ + + .DATETIME _ + + .STRING _ + + .ANNOTATION _ + + .FORMULA _ + + .HARDATTR _ + + .STYLES _ + + .OBJECTS _ + + .EDITATTR _ + + .FORMATTED + Set oRange = _ParseAddress(Range) + oRange.XCellRange.clearContents(lClear) + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SF_Documents.SF_Calc.ClearAll + +REM ----------------------------------------------------------------------------- +Public Sub ClearFormats(Optional ByVal Range As Variant) As String +''' Clear all the formatting elements of the given range +''' Args: +''' Range : the cell or the range as a string that should be cleared +''' Examples: +''' oDoc.ClearFormats("SheetX:A1:E100") ' Clear the formats of the given range + +Dim lClear As Long ' The elements to clear +Dim oRange As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.ClearFormats" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + With com.sun.star.sheet.CellFlags + lClear = 0 _ + + .HARDATTR _ + + .STYLES _ + + .EDITATTR _ + + .FORMATTED + Set oRange = _ParseAddress(Range) + oRange.XCellRange.clearContents(lClear) + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SF_Documents.SF_Calc.ClearFormats + +REM ----------------------------------------------------------------------------- +Public Sub ClearValues(Optional ByVal Range As Variant) As String +''' Clear values and formulas in the given range +''' Args: +''' Range : the cell or the range as a string that should be cleared +''' Examples: +''' oDoc.ClearValues("SheetX:*") ' Clears the used area of the sheet + +Dim lClear As Long ' The elements to clear +Dim oRange As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.ClearValues" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + With com.sun.star.sheet.CellFlags + lClear = 0 _ + + .VALUE _ + + .DATETIME _ + + .STRING _ + + .FORMULA + Set oRange = _ParseAddress(Range) + oRange.XCellRange.clearContents(lClear) + End With + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SF_Documents.SF_Calc.ClearValues + +REM ----------------------------------------------------------------------------- +Public Function CompactLeft(Optional ByVal Range As Variant _ + , Optional ByVal WholeColumn As Variant _ + , Optional ByVal FilterFormula As Variant _ + ) As String +''' Delete the columns of a specified range matching a filter expressed as a formula +''' applied on each column. +''' The deleted cells can span whole columns or be limited to the height of the range +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeColumn: when True (default = False), erase whole columns +''' FilterFormula: the formula to be applied on each column. +''' The column is erased when the formula results in True, +''' The formula shall probably involve one or more cells of the first column of the range.. +''' By default, a column is erased when all the cells of the column are empty, +''' i.e. suppose the range is "A1:J200" (height = 0) the default value becomes +''' "=(COUNTBLANK(A1:A200)=200)" +''' Returns: +''' A string representing the location of the initial range after compaction, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.CompactLeft("SheetX.G1:L10") ' All empty columns of the range are suppressed +''' newrange = oDoc.CompactLeft("SheetX.G1:L10", WholeColumn := True, FilterFormula := "=(G$7=""X"")") +''' ' The columns having a "X" in row 7 are completely suppressed + +Dim sCompact As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lLastRow As Long ' Last used row number in the sheet containing Range +Dim sFormulaRange As String ' Range, as a string, where the FilterFormula must be stored +Dim vCompact As Variant ' Array of Boolean values indicating which columns should be erased +Dim lCountDeleted As Long ' Count the deleted columns +Dim lCountToDelete As Long ' Count contiguous columns to be deleted at once +Dim sPartialRange As String ' Contiguous columns to be deleted +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.CompactLeft" +Const cstSubArgs = "Range, [WholeColumn=False], [FilterFormula=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCompact = "" + +Check: + If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False + If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Set the default formula => all cells are blank + If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C1%R2)-" & .Height & "=0)", Range) + ' Compute the range where to apply the formula + lLastRow = LastRow(.SheetName) + sFormulaRange = Offset(Range, lLastRow - .XCellRange.RangeAddress.StartColumn + 1, , 1) + SetFormula(sFormulaRange, FilterFormula) + ' Get the columns to compact: 0 = False, 1 = True + vCompact = GetValue(sFormulaRange) + If Not IsArray(vCompact) Then vCompact = Array(vCompact) + ClearAll(sFormulaRange) + + ' Iterates from the last to the first column of the range and remove the columns that match the filter + ' by groups of contiguous columns + lCountDeleted = 0 + lCountToDelete = 0 + For i = UBound(vCompact) To 0 Step -1 + If vCompact(i) = 1 Then lCountToDelete = lCountToDelete + 1 + If i > 0 And vCompact(i) = 1 Then + ' Do nothing + ElseIf lCountToDelete > 0 Then ' The current column must be kept but columns at the left must be removed + ' Do not forget when the 1st column must be removed + sPartialRange = Offset(Range, , Iif(i = 0 And vCompact(i) = 1, 0, i + 1), , lCountToDelete) + ShiftLeft(sPartialRange, WholeColumn) + lCountDeleted = lCountDeleted + lCountToDelete + lCountToDelete = 0 + End If + Next i + + ' Compute the final range position + If lCountDeleted < .Width Then sCompact = Offset(Range, 0, 0, , .Width - lCountDeleted) + + ' Push rightwards the cells that migrated leftwards irrelevantly + If Not WholeColumn Then + If Len(sCompact) > 0 Then + sPartialRange = Offset(sCompact, 0, .Width - lCountDeleted, , lCountDeleted) + Else + sPartialRange = .RangeName + End If + ShiftRight(sPartialRange, WholeColumn := False) + End If + + End With + +Finally: + CompactLeft = sCompact + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.CompactLeft + +REM ----------------------------------------------------------------------------- +Public Function CompactUp(Optional ByVal Range As Variant _ + , Optional ByVal WholeRow As Variant _ + , Optional ByVal FilterFormula As Variant _ + ) As String +''' Delete the rows of a specified range matching a filter expressed as a formula +''' applied on each row. +''' The deleted cells can span whole rows or be limited to the width of the range +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeRow: when True (default = False), erase whole rows +''' FilterFormula: the formula to be applied on each row. +''' The row is erased when the formula results in True, +''' The formula shall probably involve one or more cells of the first row of the range.. +''' By default, a row is erased when all the cells of the row are empty, +''' i.e. suppose the range is "A1:J200" (width = 10) the default value becomes +''' "=(COUNTBLANK(A1:J1)=10)" +''' Returns: +''' A string representing the location of the initial range after compaction, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.CompactUp("SheetX.G1:L10") ' All empty rows of the range are suppressed +''' newrange = oDoc.CompactUp("SheetX.G1:L10", WholeRow := True, FilterFormula := "=(G1=""X"")") +''' ' The rows having a "X" in column G are completely suppressed + +Dim sCompact As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lLastCol As Long ' Last used column number in the sheet containing Range +Dim sFormulaRange As String ' Range, as a string, where the FilterFormula must be stored +Dim vCompact As Variant ' Array of Boolean values indicating which rows should be erased +Dim lCountDeleted As Long ' Count the deleted rows +Dim lCountToDelete As Long ' Count contiguous rows to be deleted at once +Dim sPartialRange As String ' Contiguous rows to be deleted +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.CompactUp" +Const cstSubArgs = "Range, [WholeRow=False], [FilterFormula=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCompact = "" + +Check: + If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False + If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Set the default formula => all cells are blank + If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C2%R1)-" & .Width & "=0)", Range) + ' Compute the range where to apply the formula + lLastCol = LastColumn(.SheetName) + sFormulaRange = Offset(Range, , lLastCol - .XCellRange.RangeAddress.StartRow + 1, , 1) + SetFormula(sFormulaRange, FilterFormula) + ' Get the rows to compact: 0 = False, 1 = True + vCompact = GetValue(sFormulaRange) + If Not IsArray(vCompact) Then vCompact = Array(vCompact) + ClearAll(sFormulaRange) + + ' Iterates from the last to the first row of the range and remove the rows that match the filter + ' by groups of contiguous rows + lCountDeleted = 0 + lCountToDelete = 0 + For i = UBound(vCompact) To 0 Step -1 + If vCompact(i) = 1 Then lCountToDelete = lCountToDelete + 1 + If i > 0 And vCompact(i) = 1 Then + ' Do nothing + ElseIf lCountToDelete > 0 Then ' The current row must be kept but rows below must be removed + ' Do not forget when the 1st row must be removed + sPartialRange = Offset(Range, Iif(i = 0 And vCompact(i) = 1, 0, i + 1), , lCountToDelete) + ShiftUp(sPartialRange, WholeRow) + lCountDeleted = lCountDeleted + lCountToDelete + lCountToDelete = 0 + End If + Next i + + ' Compute the final range position + If lCountDeleted < .Height Then sCompact = Offset(Range, 0, 0, .Height - lCountDeleted) + + ' Push downwards the cells that migrated upwards irrelevantly + If Not WholeRow Then + If Len(sCompact) > 0 Then + sPartialRange = Offset(sCompact, .Height - lCountDeleted, 0, lCountDeleted) + Else + sPartialRange = .RangeName + End If + ShiftDown(sPartialRange, WholeRow := False) + End If + + End With + +Finally: + CompactUp = sCompact + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.CompactUp + +REM ----------------------------------------------------------------------------- +Public Function CopySheet(Optional ByVal SheetName As Variant _ + , Optional ByVal NewName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Copy a specified sheet before an existing sheet or at the end of the list of sheets +''' The sheet to copy may be inside any open Calc document +''' Args: +''' SheetName: The name of the sheet to copy or its reference +''' NewName: Must not exist +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert +''' Returns: +''' True if the sheet could be copied successfully +''' Exceptions: +''' DUPLICATESHEETERROR A sheet with the given name exists already +''' Examples: +''' oDoc.CopySheet("SheetX", "SheetY") +''' ' Copy within the same document +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods") +''' oDocB.CopySheet(oDocA.Sheet("SheetX"), "SheetY") +''' ' Copy from 1 file to another and put the new sheet at the end + +Dim bCopy As Boolean ' Return value +Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets +Dim vSheets As Variant ' List of existing sheets +Dim lSheetIndex As Long ' Index of a sheet +Dim oSheet As Object ' Alias of SheetName as reference +Dim lRandom As Long ' Output of random number generator +Dim sRandom ' Random sheet name +Const cstThisSub = "SFDocuments.Calc.CopySheet" +Const cstSubArgs = "SheetName, NewName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCopy = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True, , , True) Then GoTo Finally + If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + +Try: + ' Determine the index of the sheet before which to insert the copy + Set oSheets = _Component.getSheets + vSheets = oSheets.getElementNames() + If VarType(BeforeSheet) = V_STRING Then + lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet) + Else + lSheetIndex = BeforeSheet - 1 + If lSheetIndex < 0 Then lSheetIndex = 0 + If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1 + End If + + ' Copy sheet inside the same document OR import from another document + If VarType(SheetName) = V_STRING Then + _Component.getSheets.copyByName(SheetName, NewName, lSheetIndex) + Else + Set oSheet = SheetName + With oSheet + ' If a sheet with same name as input exists in the target sheet, rename it first with a random name + sRandom = "" + If ScriptForge.SF_Array.Contains(vSheets, .SheetName) Then + lRandom = ScriptForge.SF_Session.ExecuteCalcFunction("RANDBETWEEN", 1, 9999999) + sRandom = "SF_" & Right("0000000" & lRandom, 7) + oSheets.getByName(.SheetName).setName(sRandom) + End If + ' Import i.o. Copy + oSheets.importSheet(oSheet.Component, .SheetName, lSheetIndex) + ' Rename to new sheet name + oSheets.getByName(.SheetName).setName(NewName) + ' Reset random name + If Len(sRandom) > 0 Then oSheets.getByName(srandom).setName(.SheetName) + End With + End If + bCopy = True + +Finally: + CopySheet = bCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDuplicate: + ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, "NewName", NewName, "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopySheet + +REM ----------------------------------------------------------------------------- +Public Function CopySheetFromFile(Optional ByVal FileName As Variant _ + , Optional ByVal SheetName As Variant _ + , Optional ByVal NewName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Copy a specified sheet before an existing sheet or at the end of the list of sheets +''' The sheet to copy is located inside any closed Calc document +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' The file must not be protected with a password +''' SheetName: The name of the sheet to copy +''' NewName: Must not exist +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert +''' Returns: +''' True if the sheet could be created +''' The created sheet is blank when the input file is not a Calc file +''' The created sheet contains an error message when the input sheet was not found +''' Exceptions: +''' DUPLICATESHEETERROR A sheet with the given name exists already +''' UNKNOWNFILEERROR The input file is unknown +''' Examples: +''' oDoc.CopySheetFromFile("C:\MyFile.ods", "SheetX", "SheetY", 3) + +Dim bCopy As Boolean ' Return value +Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet +Dim sFileName As String ' URL alias of FileName +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Calc.CopySheetFromFile" +Const cstSubArgs = "FileName, SheetName, NewName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bCopy = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SheetName, "SheetName", V_STRING) Then GoTo Finally + If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + +Try: + Set FSO = ScriptForge.SF_FileSystem + ' Does the input file exist ? + If Not FSO.FileExists(FileName) Then GoTo CatchNotExists + sFileName = FSO._ConvertToUrl(FileName) + + ' Insert a blank new sheet and import sheet from file via link setting and deletion + If Not InsertSheet(Newname, BeforeSheet) Then GoTo Finally + Set oSheet = _Component.getSheets.getByName(NewName) + With oSheet + .link(sFileName,SheetName, "", "", com.sun.star.sheet.SheetLinkMode.NORMAL) + .LinkMode = com.sun.star.sheet.SheetLinkMode.NONE + .LinkURL = "" + End With + bCopy = True + +Finally: + CopySheetFromFile = bCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotExists: + ScriptForge.SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName) + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopySheetFromFile + +REM ----------------------------------------------------------------------------- +Public Function CopyToCell(Optional ByVal SourceRange As Variant _ + , Optional ByVal DestinationCell As Variant _ + ) As String +''' Copy a specified source range to a destination range or cell +''' The source range may belong to another open document +''' The method imitates the behaviour of a Copy/Paste from a range to a single cell +''' Args: +''' SourceRange: the source range as a string if it belongs to the same document +''' or as a reference if it belongs to another open Calc document +''' DestinationCell: the destination of the copied range of cells, as a string +''' If given as a range of cells, the destination will be reduced to its top-left cell +''' Returns: +''' A string representing the modified range of cells +''' The modified area depends only on the size of the source area +''' Examples: +''' oDoc.CopyToCell("SheetX.A1:F10", "SheetY.C5") +''' ' Copy within the same document +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods") +''' oDocB.CopyToCell(oDocA.Range("SheetX.A1:F10"), "SheetY.C5") +''' ' Copy from 1 file to another + +Dim sCopy As String ' Return value +Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error +Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim oSelect As Object ' Current selection in source +Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable + +Const cstThisSub = "SFDocuments.Calc.CopyToCell" +Const cstSubArgs = "SourceRange, DestinationCell" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCopy = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + End If + +Try: + If VarType(SourceRange) = V_STRING Then ' Same document - Use UNO copyRange method + Set oSourceAddress = _ParseAddress(SourceRange).XCellRange.RangeAddress + Set oDestRange = _ParseAddress(DestinationCell) + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = New com.sun.star.table.CellAddress + With oDestAddress + oDestCell.Sheet = .Sheet + oDestCell.Column = .StartColumn + oDestCell.Row = .StartRow + End With + oDestRange.XSpreadsheet.copyRange(oDestCell, oSourceAddress) + Else ' Use clipboard to copy - current selection in Source should be preserved + Set oSource = SourceRange + With oSource + ' Keep current selection in source document + Set oSelect = .Component.CurrentController.getSelection() + ' Select, copy the source range and paste in the top-left cell of the destination + .Component.CurrentController.select(.XCellRange) + Set oClipboard = .Component.CurrentController.getTransferable() + _Component.CurrentController.select(_Offset(DestinationCell, 0, 0, 1, 1).XCellRange) + _Component.CurrentController.insertTransferable(oClipBoard) + ' Restore previous selection in Source + _RestoreSelections(.Component, oSelect) + Set oSourceAddress = .XCellRange.RangeAddress + End With + End If + + With oSourceAddress + sCopy = _Offset(DestinationCell, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName + End With + +Finally: + CopyToCell = sCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopyToCell + +REM ----------------------------------------------------------------------------- +Public Function CopyToRange(Optional ByVal SourceRange As Variant _ + , Optional ByVal DestinationRange As Variant _ + ) As String +''' Copy downwards and/or rightwards a specified source range to a destination range +''' The source range may belong to another open document +''' The method imitates the behaviour of a Copy/Paste from a range to a larger range +''' If the height (resp. width) of the destination area is > 1 row (resp. column) +''' then the height (resp. width) of the source must be <= the height (resp. width) +''' of the destination. Otherwise nothing happens +''' If the height (resp.width) of the destination is = 1 then the destination +''' is expanded downwards (resp. rightwards) up to the height (resp. width) +''' of the source range +''' Args: +''' SourceRange: the source range as a string if it belongs to the same document +''' or as a reference if it belongs to another open Calc document +''' DestinationRange: the destination of the copied range of cells, as a string +''' Returns: +''' A string representing the modified range of cells +''' Examples: +''' oDoc.CopyToRange("SheetX.A1:F10", "SheetY.C5:J5") +''' ' Copy within the same document +''' ' Returned range: $SheetY.$C$5:$J$14 +''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True) +''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods") +''' oDocB.CopyToRange(oDocA.Range("SheetX.A1:F10"), "SheetY.C5:J5") +''' ' Copy from 1 file to another + +Dim sCopy As String ' Return value +Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error +Dim oDestRange As Object ' Destination as a range +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim oSelect As Object ' Current selection in source +Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable +Dim bSameDocument As Boolean ' True when source in same document as destination +Dim lHeight As Long ' Height of destination +Dim lWidth As Long ' Width of destination + +Const cstThisSub = "SFDocuments.Calc.CopyToRange" +Const cstSubArgs = "SourceRange, DestinationRange" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCopy = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationRange, "DestinationRange", V_STRING) Then GoTo Finally + End If + +Try: + ' Copy done via clipboard + + ' Check Height/Width destination = 1 or > Height/Width of source + bSameDocument = ( VarType(SourceRange) = V_STRING ) + If bSameDocument Then Set oSource = _ParseAddress(SourceRange) Else Set oSource = SourceRange + Set oDestRange = _ParseAddress(DestinationRange) + With oDestRange + lHeight = .Height + lWidth = .Width + If lHeight = 1 Then + lHeight = oSource.Height ' Future height + ElseIf lHeight < oSource.Height Then + GoTo Finally + End If + If lWidth = 1 Then + lWidth = oSource.Width ' Future width + ElseIf lWidth < oSource.Width Then + GoTo Finally + End If + End With + + With oSource + ' Store actual selection in source + Set oSelect = .Component.CurrentController.getSelection() + ' Select, copy the source range and paste in the destination + .Component.CurrentController.select(.XCellRange) + Set oClipboard = .Component.CurrentController.getTransferable() + _Component.CurrentController.select(oDestRange.XCellRange) + _Component.CurrentController.insertTransferable(oClipBoard) + ' Restore selection in source + _RestoreSelections(.Component, oSelect) + End With + + sCopy = _Offset(oDestRange, 0, 0, lHeight, lWidth).RangeName + +Finally: + CopyToRange = sCopy + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.CopyToRange + +REM ----------------------------------------------------------------------------- +Public Function CreateChart(Optional ByVal ChartName As Variant _ + , Optional ByVal SheetName As Variant _ + , Optional ByVal Range As Variant _ + , Optional ColumnHeader As Variant _ + , Optional RowHeader As Variant _ + ) As Variant +''' Return a new chart instance initialized with default values +''' Args: +''' ChartName: The user-defined name of the new chart +''' SheetName: The name of an existing sheet +''' Range: the cell or the range as a string that should be drawn +''' ColumnHeader: when True, the topmost row of the range will be used to set labels for the category axis or the legend. +''' Default = False +''' RowHeader: when True, the leftmost column of the range will be used to set labels for the category axis or the legend. +''' Default = False +''' Returns: +''' A new chart service instance +''' Exceptions: +''' DUPLICATECHARTERROR A chart with the same name exists already in the given sheet +''' Examples: +''' Dim oChart As Object +''' Set oChart = oDoc.CreateChart("myChart", "SheetX", "A1:C8", ColumnHeader := True) + +Dim oChart As Object ' Return value +Dim vCharts As Variant ' List of pre-existing charts +Dim oSheet As Object ' Alias of SheetName as reference +Dim oRange As Object ' Alias of Range +Dim oRectangle as new com.sun.star.awt.Rectangle ' Simple shape + +Const cstThisSub = "SFDocuments.Calc.CreateChart" +Const cstSubArgs = "ChartName, SheetName, Range, [ColumnHeader=False], [RowHeader=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oChart = Nothing + +Check: + If IsMissing(RowHeader) Or IsEmpty(RowHeader) Then Rowheader = False + If IsMissing(ColumnHeader) Or IsEmpty(ColumnHeader) Then ColumnHeader = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ColumnHeader, "ColumnHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(RowHeader, "RowHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + vCharts = Charts(SheetName) + If ScriptForge.SF_Array.Contains(vCharts, ChartName, CaseSensitive := True) Then GoTo CatchDuplicate + +Try: + ' The rectangular shape receives arbitrary values. User can Resize() it later + With oRectangle + .X = 0 : .Y = 0 + .Width = 8000 : .Height = 6000 + End With + ' Initialize sheet and range + Set oSheet = _Component.getSheets.getByName(SheetName) + Set oRange = _ParseAddress(Range) + ' Create the chart and get ihe corresponding chart instance + oSheet.getCharts.addNewByName(ChartName, oRectangle, Array(oRange.XCellRange.RangeAddress), ColumnHeader, RowHeader) + Set oChart = Charts(SheetName, ChartName) + oChart._Shape.Name = ChartName ' Both user-defined and internal names match ChartName + oChart._Diagram.Wall.FillColor = RGB(255, 255, 255) ' Align on background color set by the user interface by default + +Finally: + Set CreateChart = oChart + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchDuplicate: + ScriptForge.SF_Exception.RaiseFatal(DUPLICATECHARTERROR, "ChartName", ChartName, "SheetName", SheetName, "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc.CreateChart + +REM ----------------------------------------------------------------------------- +Public Function CreatePivotTable(Optional ByVal PivotTableName As Variant _ + , Optional ByVal SourceRange As Variant _ + , Optional ByVal TargetCell As Variant _ + , Optional ByRef DataFields As Variant _ + , Optional ByRef RowFields As Variant _ + , Optional ByRef ColumnFields As Variant _ + , Optional ByVal FilterButton As Variant _ + , Optional ByVal RowTotals As Variant _ + , Optional ByVal ColumnTotals As Variant _ + ) As String +''' Create a new pivot table with the properties defined by the arguments. +''' If a pivot table with the same name exists already in the targeted sheet, it will be erased without warning. +''' Args: +''' PivotTableName: The user-defined name of the new pivottable +''' SourceRange: The range as a string containing the raw data. +''' The first row of the range is presumed to contain the field names of the new pivot table +''' TargetCell: the top left cell or the range as a string where to locate the pivot table. +''' Only the top left cell of the range will be considered. +''' DataFields: A single string or an array of field name + function to apply, formatted like: +''' Array("FieldName[;Function]", ...) +''' The allowed functions are: Sum, Count, Average, Max, Min, Product, CountNums, StDev, StDevP, Var, VarP and Median. +''' The default function is: When the values are all numerical, Sum is used, otherwise Count +''' RowFields: A single string or an array of the field names heading the pivot table rows +''' ColumnFields: A single string or an array of the field names heading the pivot table columns +''' FilterButton: When True (default), display a "Filter" button above the pivot table +''' RowTotals: When True (default), display a separate column for row totals +''' ColumnTotals: When True (default), display a separate row for column totals +''' Returns: +''' Return the range where the new pivot table is deployed. +''' Examples: +''' Dim vData As Variant, oDoc As Object, sTable As String, sPivot As String +''' vData = Array(Array("Item", "State", "Team", "2002", "2003", "2004"), _ +''' Array("Books", "Michigan", "Jean", 14788, 30222, 23490), _ +''' Array("Candy", "Michigan", "Jean", 26388, 15641, 32849), _ +''' Array("Pens", "Michigan", "Jean", 16569, 32675, 25396), _ +''' Array("Books", "Michigan", "Volker", 21961, 21242, 29009), _ +''' Array("Candy", "Michigan", "Volker", 26142, 22407, 32841)) +''' Set oDoc = ui.CreateDocument("Calc") +''' sTable = oDoc.SetArray("A1", vData) +''' sPivot = oDoc.CreatePivotTable("PT1", sTable, "H1", Array("2002", "2003;count", "2004;average"), "Item", Array("State", "Team"), False) + +Dim sPivotTable As String ' Return value +Dim vData As Variant ' Alias of DataFields +Dim vRows As Variant ' Alias of RowFields +Dim vColumns As Variant ' Alias of ColumnFields +Dim oSourceAddress As Object ' Source as an _Address +Dim oTargetAddress As Object ' Target as an _Address +Dim vHeaders As Variant ' Array of header fields in the source range +Dim oPivotTables As Object ' com.sun.star.sheet.XDataPilotTables +Dim oDescriptor As Object ' com.sun.star.sheet.DataPilotDescriptor +Dim oFields As Object ' ScDataPilotFieldsObj - Collection of fields +Dim oField As Object ' ScDataPilotFieldsObj - A single field +Dim sField As String ' A single field name +Dim sData As String ' A single data field name + function +Dim vDataField As Variant ' A single vData element, split on semicolon +Dim sFunction As String ' Function to apply on a data field (string) +Dim iFunction As Integer ' Equivalent of sFunction as com.sun.star.sheet.GeneralFunction2 constant +Dim oOutputRange As Object ' com.sun.star.table.CellRangeAddress +Dim i As Integer + +Const cstThisSub = "SFDocuments.Calc.CreatePivotTable" +Const cstSubArgs = "PivotTableName, SourceRange, TargetCell, DataFields, [RowFields], [ColumnFields]" _ + & ", [FilterButton=True], [RowTotals=True], [ColumnTotals=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sPivotTable = "" + +Check: + If IsMissing(RowFields) Or IsEmpty(RowFields) Then RowFields = Array() + If IsMissing(ColumnFields) Or IsEmpty(ColumnFields) Then ColumnFields = Array() + If IsMissing(FilterButton) Or IsEmpty(FilterButton) Then FilterButton = True + If IsMissing(RowTotals) Or IsEmpty(RowTotals) Then RowTotals = True + If IsMissing(ColumnTotals) Or IsEmpty(ColumnTotals) Then ColumnTotals = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PivotTableName, "PivotTableName", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally + If IsArray(DataFields) Then + If Not ScriptForge.SF_Utils._ValidateArray(DataFields, "DataFields", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(DataFields, "DataFields", V_STRING) Then GoTo Finally + End If + If IsArray(RowFields) Then + If Not ScriptForge.SF_Utils._ValidateArray(RowFields, "RowFields", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(RowFields, "RowFields", V_STRING) Then GoTo Finally + End If + If IsArray(ColumnFields) Then + If Not ScriptForge.SF_Utils._ValidateArray(ColumnFields, "ColumnFields", 1, V_STRING, True) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(ColumnFields, "ColumnFields", V_STRING) Then GoTo Finally + End If + If Not ScriptForge.SF_Utils._Validate(FilterButton, "FilterButton", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(RowTotals, "RowTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ColumnTotals, "ColumnTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + ' Next statements must be outside previous If-block to force their execution even in case of internal call + If IsArray(DataFields) Then vData = DataFields Else vData = Array(DataFields) + If IsArray(RowFields) Then vRows = RowFields Else vRows = Array(RowFields) + If IsArray(ColumnFields) Then vColumns = ColumnFields Else vColumns = Array(ColumnFields) + +Try: + + Set oSourceAddress = _ParseAddress(SourceRange) + vHeaders = GetValue(Offset(SourceRange, 0, 0, 1)) ' Content of the first row of the source + Set oTargetAddress = _Offset(TargetCell, 0, 0, 1, 1) ' Retain the top left cell only + Set oPivotTables = oTargetAddress.XSpreadsheet.getDataPilotTables() + + ' Initialize new pivot table + Set oDescriptor = oPivotTables.createDataPilotDescriptor() + oDescriptor.setSourceRange(oSourceAddress.XCellRange.RangeAddress) + Set oFields = oDescriptor.getDataPilotFields() + + ' Set row fields + For i = 0 To UBound(vRows) + sField = vRows(i) + If Len(sField) > 0 Then + If Not ScriptForge.SF_Utils._Validate(sField, "RowFields", V_STRING, vHeaders) Then GoTo Finally + Set oField = oFields.getByName(sField) + oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.ROW + End If + Next i + + ' Set column fields + For i = 0 To UBound(vColumns) + sField = vColumns(i) + If Len(sField) > 0 Then + If Not ScriptForge.SF_Utils._Validate(sField, "ColumnFields", V_STRING, vHeaders) Then GoTo Finally + Set oField = oFields.getByName(sField) + oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.COLUMN + End If + Next i + + ' Set data fields + For i = 0 To UBound(vData) + sData = vData(i) + ' Minimal parsing + If Right(sData, 1) = ";" Then sData = Left(sData, Len(sData) - 1) + vDataField = Split(sData, ";") + sField = vDataField(0) + If UBound(vDataField) > 0 Then sFunction = vDataField(1) Else sFunction = "" + ' Define field properties + If Len(sField) > 0 Then + If Not ScriptForge.SF_Utils._Validate(sField, "DataFields", V_STRING, vHeaders) Then GoTo Finally + Set oField = oFields.getByName(sField) + oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.DATA + ' Associate the correct function + With com.sun.star.sheet.GeneralFunction2 + Select Case UCase(sFunction) + Case "" : iFunction = .AUTO + Case "SUM" : iFunction = .SUM + Case "COUNT" : iFunction = .COUNT + Case "AVERAGE" : iFunction = .AVERAGE + Case "MAX" : iFunction = .MAX + Case "MIN" : iFunction = .MIN + Case "PRODUCT" : iFunction = .PRODUCT + Case "COUNTNUMS": iFunction = .COUNTNUMS + Case "STDEV" : iFunction = .STDEV + Case "STDEVP" : iFunction = .STDEVP + Case "VAR" : iFunction = .VAR + Case "VARP" : iFunction = .VARP + Case "MEDIAN" : iFunction = .MEDIAN + Case Else + If Not ScriptForge.SF_Utils._Validate(sFunction, "DataFields/Function", V_STRING _ + , Array("Sum", "Count", "Average", "Max", "Min", "Product", "CountNums" _ + , "StDev", "StDevP", "Var", "VarP", "Median") _ + ) Then GoTo Finally + End Select + End With + oField.Function2 = iFunction + End If + Next i + + ' Remove any pivot table with same name + If oPivotTables.hasByName(PivotTableName) Then oPivotTables.removeByName(PivotTableName) + + ' Finalize the new pivot table + oDescriptor.ShowFilterButton = FilterButton + oDescriptor.RowGrand = RowTotals + oDescriptor.ColumnGrand = ColumnTotals + oPivotTables.insertNewByName(PivotTableName, oTargetAddress.XCellRange.getCellByPosition(0, 0).CellAddress, oDescriptor) + + ' Determine the range of the new pivot table + Set oOutputRange = oPivotTables.getByName(PivotTableName).OutputRange + With oOutputRange + sPivotTable = _Component.getSheets().getCellRangeByPosition(.StartColumn, .StartRow, .EndColumn, .EndRow, .Sheet).AbsoluteName + End With + +Finally: + CreatePivotTable = sPivotTable + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.CreatePivotTable + +REM ----------------------------------------------------------------------------- +Public Function DAvg(Optional ByVal Range As Variant) As Double +''' Get the average of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The average of the numeric values as a double +''' Examples: +''' Val = oDoc.DAvg("~.A1:A1000") + +Try: + DAvg = _DFunction("DAvg", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DAvg + +REM ----------------------------------------------------------------------------- +Public Function DCount(Optional ByVal Range As Variant) As Long +''' Get the number of numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The number of numeric values as a Long +''' Examples: +''' Val = oDoc.DCount("~.A1:A1000") + +Try: + DCount = _DFunction("DCount", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DCount + +REM ----------------------------------------------------------------------------- +Public Function DMax(Optional ByVal Range As Variant) As Double +''' Get the greatest of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The greatest of the numeric values as a double +''' Examples: +''' Val = oDoc.DMax("~.A1:A1000") + +Try: + DMax = _DFunction("DMax", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DMax + +REM ----------------------------------------------------------------------------- +Public Function DMin(Optional ByVal Range As Variant) As Double +''' Get the smallest of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The smallest of the numeric values as a double +''' Examples: +''' Val = oDoc.DMin("~.A1:A1000") + +Try: + DMin = _DFunction("DMin", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DMin + +REM ----------------------------------------------------------------------------- +Public Function DSum(Optional ByVal Range As Variant) As Double +''' Get sum of the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to get the values from +''' Returns: +''' The sum of the numeric values as a double +''' Examples: +''' Val = oDoc.DSum("~.A1:A1000") + +Try: + DSum = _DFunction("DSum", Range) + +Finally: + Exit Function +End Function ' SF_Documents.SF_Calc.DSum + +REM ----------------------------------------------------------------------------- +Public Function ExportRangeToFile(Optional ByVal Range As Variant _ + , Optional ByVal FileName As Variant _ + , Optional ByVal ImageType As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Store the given range as an image to the given file location +''' Actual selections are not impacted +''' Inspired by https://stackoverflow.com/questions/30509532/how-to-export-cell-range-to-pdf-file +''' Args: +''' Range: sheet name or cell range to be exported, as a string +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' ImageType: the name of the targeted media type +''' Allowed values: jpeg, pdf (default) and png +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' RANGEEXPORTERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.ExportRangeToFile('SheetX.B2:J15", "C:\Me\Range2.png", ImageType := "png", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vStoreArguments As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vFilterData As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Dim vImageTypes As Variant ' Array of permitted image types +Dim vFilters As Variant ' Array of corresponding filters in the same order as vImageTypes +Dim sFilter As String ' The filter to apply +Dim oSelect As Object ' Currently selected range(s) +Dim oAddress As Object ' Alias of Range + +Const cstImageTypes = "jpeg,pdf,png" +Const cstFilters = "calc_jpg_Export,calc_pdf_Export,calc_png_Export" + +Const cstThisSub = "SFDocuments.Calc.ExportRangeToFile" +Const cstSubArgs = "Range, FileName, [ImageType=""pdf""|""jpeg""|""png""], [Overwrite=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(ImageType) Or IsEmpty(ImageType) Then ImageType = "pdf" + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + + vImageTypes = Split(cstImageTypes, ",") + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ImageType, "ImageType", V_STRING, vImageTypes) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + vFilters = Split(cstFilters, ",") + sFilter = vFilters(ScriptForge.SF_Array.IndexOf(vImageTypes, ImageType, CaseSensitive := False)) + Set oAddress = _ParseAddress(Range) + + ' The filter arguments differ between + ' 1) pdf : store range in Selection property value + ' 2) png, jpeg : save current selection, select range, restore initial selection + If LCase(ImageType) = "pdf" Then + vFilterData = Array(ScriptForge.SF_Utils._MakePropertyValue("Selection", oAddress.XCellRange) ) + vStoreArguments = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterData", vFilterData) _ + ) + Else ' png, jpeg + ' Save the current selection(s) + Set oSelect = _Component.CurrentController.getSelection() + _Component.CurrentController.select(oAddress.XCellRange) + vStoreArguments = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ + , ScriptForge.SF_Utils._MakePropertyValue("SelectionOnly", True) _ + ) + End If + + ' Apply the filter and export + _Component.storeToUrl(sFile, vStoreArguments) + If LCase(ImageType) <> "pdf" Then _RestoreSelections(_Component, oSelect) + + bSaved = True + +Finally: + ExportRangeToFile = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(RANGEEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite) + GoTo Finally +End Function ' SFDocuments.SF_Chart.ExportRangeToFile + +REM ----------------------------------------------------------------------------- +Public Function Forms(Optional ByVal SheetName As Variant _ + , Optional ByVal Form As Variant _ + ) As Variant +''' Return either +''' - the list of the Forms contained in the given sheet +''' - a SFDocuments.Form object based on its name or its index +''' Args: +''' SheetName: the name of the sheet containing the requested form or forms +''' Form: a form stored in the document given by its name or its index +''' When absent, the list of available forms is returned +''' To get the first (unique ?) form stored in the form document, set Form = 0 +''' Exceptions: +''' CALCFORMNOTFOUNDERROR Form not found +''' Returns: +''' A zero-based array of strings if Form is absent +''' An instance of the SF_Form class if Form exists +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.Forms("ThisSheet") +''' Set myForm = oDoc.Forms("ThisSheet", 0) + +Dim oForm As Object ' The new Form class instance +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Dim oXForm As Object ' com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +Dim vFormNames As Variant ' Array of form names +Dim oForms As Object ' Forms collection +Const cstDrawPage = -1 ' There is no DrawPages collection in Calc sheets + +Const cstThisSub = "SFDocuments.Calc.Forms" +Const cstSubArgs = "SheetName, [Form=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Form) Or IsEmpty(Form) Then Form = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + +Try: + ' Start from the Calc sheet and go down to forms + Set oForms = _Component.getSheets.getByName(SheetName).DrawPage.Forms + vFormNames = oForms.getElementNames() + + If Len(Form) = 0 Then ' Return the list of valid form names + Forms = vFormNames + Else + If VarType(Form) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Utils._Validate(Form, "Form", V_STRING, vFormNames) Then GoTo Finally + Set oXForm = oForms.getByName(Form) + Else ' Find the form by index + If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound + Set oXForm = oForms.getByIndex(Form) + End If + ' Create the new Form class instance + Set oForm = SF_Register._NewForm(oXForm) + With oForm + Set .[_Parent] = [Me] + ._SheetName = SheetName + ._FormType = ISCALCFORM + Set ._Component = _Component + ._Initialize() + End With + Set Forms = oForm + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(CALCFORMNOTFOUNDERROR, Form, _FileIdent()) +End Function ' SFDocuments.SF_Calc.Forms + +REM ----------------------------------------------------------------------------- +Function GetColumnName(Optional ByVal ColumnNumber As Variant) As String +''' Convert a column number (range 1, 2,..1024) into its letter counterpart (range 'A', 'B',..'AMJ'). +''' Args: +''' ColumnNumber: the column number, must be in the interval 1 ... 1024 +''' Returns: +''' a string representation of the column name, in range 'A'..'AMJ' +''' If ColumnNumber is not in the allowed range, returns a zero-length string +''' Example: +''' MsgBox oDoc.GetColumnName(1022) ' "AMH" +''' Adapted from a Python function by sundar nataraj +''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter + +Dim sCol As String ' Return value +Const cstThisSub = "SFDocuments.Calc.GetColumnName" +Const cstSubArgs = "ColumnNumber" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sCol = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(ColumnNumber, "ColumnNumber", V_NUMERIC) Then GoTo Finally + End If + +Try: + If (ColumnNumber > 0) And (ColumnNumber <= MAXCOLS) Then sCol = _GetColumnName(ColumnNumber) + +Finally: + GetColumnName = sCol + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.GetColumnName + +REM ----------------------------------------------------------------------------- +Public Function GetFormula(Optional ByVal Range As Variant) As Variant +''' Get the formula(e) stored in the given range of cells +''' Args: +''' Range : the range as a string where to get the formula from +''' Returns: +''' A scalar, a zero-based 1D array or a zero-based 2D array of strings +''' Examples: +''' Val = oDoc.GetFormula("~.A1:A1000") + +Dim vGet As Variant ' Return value +Dim oAddress As Object ' Alias of Range +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.GetFormula" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vGet = Empty + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + ' Get the data + Set oAddress = _ParseAddress(Range) + vDataArray = oAddress.XCellRange.getFormulaArray() + + ' Convert the data array to scalar, vector or array + vGet = _ConvertFromDataArray(vDataArray) + +Finally: + GetFormula = vGet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.GetFormula + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant _ + , Optional ObjectName As Variant _ + ) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' ObjectName: a sheet or range name +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Calc.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If IsMissing(ObjectName) Or IsEMpty(ObjectName) Then ObjectName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(ObjectName, "ObjectName", V_STRING) Then GoTo Catch + End If + +Try: + ' Superclass or subclass property ? + If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then + GetProperty = [_Super].GetProperty(PropertyName) + ElseIf Len(ObjectName) = 0 Then + GetProperty = _PropertyGet(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName, ObjectName) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function GetValue(Optional ByVal Range As Variant) As Variant +''' Get the value(s) stored in the given range of cells +''' Args: +''' Range : the range as a string where to get the value from +''' Returns: +''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and doubles +''' To convert doubles to dates, use the CDate builtin function +''' Examples: +''' Val = oDoc.GetValue("~.A1:A1000") + +Dim vGet As Variant ' Return value +Dim oAddress As Object ' Alias of Range +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.GetValue" +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vGet = Empty + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + ' Get the data + Set oAddress = _ParseAddress(Range) + vDataArray = oAddress.XCellRange.getDataArray() + + ' Convert the data array to scalar, vector or array + vGet = _ConvertFromDataArray(vDataArray) + +Finally: + GetValue = vGet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.GetValue + +REM ----------------------------------------------------------------------------- +Public Function ImportFromCSVFile(Optional ByVal FileName As Variant _ + , Optional ByVal DestinationCell As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As String +''' Import the content of a CSV-formatted text file starting from a given cell +''' Beforehand the destination area will be cleared from any content and format +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' DestinationCell: the destination of the copied range of cells, as a string +''' If given as range, the destination will be reduced to its top-left cell +''' FilterOptions: The arguments of the CSV input filter. +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options_for_the_CSV_Filter +''' Default: input file encoding is UTF8 +''' separator = comma, semi-colon or tabulation +''' string delimiter = double quote +''' all lines are included +''' quoted strings are formatted as texts +''' special numbers are detected +''' all columns are presumed texts +''' language = english/US => decimal separator is ".", thousands separator = "," +''' Returns: +''' A string representing the modified range of cells +''' The modified area depends only on the content of the source file +''' Exceptions: +''' DOCUMENTOPENERROR The csv file could not be opened +''' Examples: +''' oDoc.ImportFromCSVFile("C:\Temp\myCsvFile.csv", "SheetY.C5") + +Dim sImport As String ' Return value +Dim oUI As Object ' UI service +Dim oSource As Object ' New Calc document with csv loaded +Dim oSelect As Object ' Current selection in destination + +Const cstFilter = "Text - txt - csv (StarCalc)" +Const cstFilterOptions = "9/44/59/MRG,34,76,1,,1033,true,true" +Const cstThisSub = "SFDocuments.Calc.ImportFromCSVFile" +Const cstSubArgs = "FileName, DestinationCell, [FilterOptions]=""9/44/59/MRG,34,76,1,,1033,true,true""" + +' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sImport = "" + +Check: + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = cstFilterOptions + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + End If + +Try: + ' Input file is loaded in an empty worksheet. Data are copied to destination cell + Set oUI = CreateScriptService("UI") + Set oSource = oUI.OpenDocument(FileName _ + , ReadOnly := True _ + , Hidden := True _ + , FilterName := cstFilter _ + , FilterOptions := FilterOptions _ + ) + ' Remember current selection and restore it after copy + Set oSelect = _Component.CurrentController.getSelection() + sImport = CopyToCell(oSource.Range("*"), DestinationCell) + _RestoreSelections(_Component, oSelect) + +Finally: + If Not IsNull(oSource) Then oSource.CloseDocument(False) + ImportFromCSVFile = sImport + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.ImportFromCSVFile + +REM ----------------------------------------------------------------------------- +Public Sub ImportFromDatabase(Optional ByVal FileName As Variant _ + , Optional ByVal RegistrationName As Variant _ + , Optional ByVal DestinationCell As Variant _ + , Optional ByVal SQLCommand As Variant _ + , Optional ByVal DirectSQL As Variant _ + ) +''' Import the content of a database table, query or resultset, i.e. the result of a SELECT SQL command, +''' starting from a given cell +''' Beforehand the destination area will be cleared from any content and format +''' The modified area depends only on the content of the source data +''' Args: +''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation +''' RegistrationName: the name of a registered database +''' It is ignored if FileName <> "" +''' DestinationCell: the destination of the copied range of cells, as a string +''' If given as a range of cells, the destination will be reduced to its top-left cell +''' SQLCommand: either a table or query name (without square brackets) +''' or a full SQL commands where table and fieldnames are preferably surrounded with square brackets +''' Returns: +''' Implemented as a Sub because the doImport UNO method does not return any error +''' Exceptions: +''' BASEDOCUMENTOPENERROR The database file could not be opened +''' Examples: +''' oDoc.ImportFromDatabase("C:\Temp\myDbFile.odb", , "SheetY.C5", "SELECT * FROM [Employees] ORDER BY [LastName]") + +Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext +Dim oDatabase As Object ' SFDatabases.Database service +Dim lCommandType As Long ' A com.sun.star.sheet.DataImportMode.xxx constant +Dim oQuery As Object ' com.sun.star.ucb.XContent +Dim bDirect As Boolean ' Alias of DirectSQL +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.XCell +Dim oSelect As Object ' Current selection in destination +Dim vImportOptions As Variant ' Array of PropertyValues + +Const cstThisSub = "SFDocuments.Calc.ImportFromDatabase" +Const cstSubArgs = "[FileName=""""], [RegistrationName=""""], DestinationCell, SQLCommand, [DirectSQL=False]" + +' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + + If IsMissing(FileName) Or IsEmpty(FileName) Then FileName = "" + If IsMissing(RegistrationName) Or IsEmpty(RegistrationName) Then RegistrationName = "" + If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName", , True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check the existence of FileName + If Len(FileName) = 0 Then ' FileName has precedence over RegistrationName + If Len(RegistrationName) = 0 Then GoTo CatchError + Set oDBContext = ScriptForge.SF_Utils._GetUNOService("DatabaseContext") + If Not oDBContext.hasRegisteredDatabase(RegistrationName) Then GoTo CatchError + FileName = ScriptForge.SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(RegistrationName)) + End If + If Not ScriptForge.SF_FileSystem.FileExists(FileName) Then GoTo CatchError + +Try: + ' Check command type + Set oDatabase = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database", FileName, , True) ' Read-only + If IsNull(oDatabase) Then GoTo CatchError + With oDatabase + If ScriptForge.SF_Array.Contains(.Tables, SQLCommand) Then + bDirect = True + lCommandType = com.sun.star.sheet.DataImportMode.TABLE + ElseIf ScriptForge.SF_Array.Contains(.Queries, SQLCommand) Then + Set oQuery = .XConnection.Queries.getByName(SQLCommand) + bDirect = Not oQuery.EscapeProcessing + lCommandType = com.sun.star.sheet.DataImportMode.QUERY + Else + bDirect = DirectSQL + lCommandType = com.sun.star.sheet.DataImportMode.SQL + SQLCommand = ._ReplaceSquareBrackets(SQLCommand) + End If + .CloseDatabase() + Set oDatabase = oDatabase.Dispose() + End With + + ' Determine the destination cell as the top-left coordinates of the given range + Set oDestRange = _ParseAddress(DestinationCell) + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = oDestRange.XSpreadsheet.getCellByPosition(oDestAddress.StartColumn, oDestAddress.StartRow) + + ' Remember current selection + Set oSelect = _Component.CurrentController.getSelection() + ' Import arguments + vImportOptions = Array(_ + ScriptForge.SF_Utils._MakePropertyValue("DatabaseName", ScriptForge.SF_FileSystem._ConvertToUrl(FileName)) _ + , ScriptForge.SF_Utils._MakePropertyValue("SourceObject", SQLCommand) _ + , ScriptForge.SF_Utils._MakePropertyValue("SourceType", lCommandType) _ + , ScriptForge.SF_Utils._MakePropertyValue("IsNative", bDirect) _ + ) + oDestCell.doImport(vImportOptions) + ' Restore selection after import_ + _RestoreSelections(_Component, oSelect) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +CatchError: + SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", FileName, "RegistrationName", RegistrationName) + GoTo Finally +End Sub ' SFDocuments.SF_Calc.ImportFromDatabase + +REM ----------------------------------------------------------------------------- +Public Function InsertSheet(Optional ByVal SheetName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Insert a new empty sheet before an existing sheet or at the end of the list of sheets +''' Args: +''' SheetName: The name of the new sheet +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert +''' Returns: +''' True if the sheet could be inserted successfully +''' Examples: +''' oDoc.InsertSheet("SheetX", "SheetY") + +Dim bInsert As Boolean ' Return value +Dim vSheets As Variant ' List of existing sheets +Dim lSheetIndex As Long ' Index of a sheet +Const cstThisSub = "SFDocuments.Calc.InsertSheet" +Const cstSubArgs = "SheetName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bInsert = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + vSheets = _Component.getSheets.getElementNames() + +Try: + If VarType(BeforeSheet) = V_STRING Then + lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet) + Else + lSheetIndex = BeforeSheet - 1 + If lSheetIndex < 0 Then lSheetIndex = 0 + If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1 + End If + _Component.getSheets.insertNewByName(SheetName, lSheetIndex) + bInsert = True + +Finally: + InsertSheet = binsert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.InsertSheet + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Calc service as an array + + Methods = Array( _ + "A1Style" _ + , "Charts" _ + , "ClearAll" _ + , "ClearFormats" _ + , "ClearValues" _ + , "CopySheet" _ + , "CopySheetFromFile" _ + , "CopyToCell" _ + , "CopyToRange" _ + , "CreateChart" _ + , "DAvg" _ + , "DCount" _ + , "DMax" _ + , "DMin" _ + , "DSum" _ + , "ExportRangeToFile" _ + , "GetColumnName" _ + , "GetFormula" _ + , "GetValue" _ + , "ImportFromCSVFile" _ + , "ImportFromDatabase" _ + , "InsertSheet" _ + , "MoveRange" _ + , "MoveSheet" _ + , "Offset" _ + , "OpenRangeSelector" _ + , "Printf" _ + , "PrintOut" _ + , "RemoveSheet" _ + , "RenameSheet" _ + , "SetArray" _ + , "SetCellStyle" _ + , "SetFormula" _ + , "SetValue" _ + , "ShiftDown" _ + , "ShiftLeft" _ + , "ShiftRight" _ + , "ShiftUp" _ + , "SortRange" _ + ) + +End Function ' SFDocuments.SF_Calc.Methods + +REM ----------------------------------------------------------------------------- +Public Function MoveRange(Optional ByVal Source As Variant _ + , Optional ByVal Destination As Variant _ + ) As String +''' Move a specified source range to a destination range +''' Args: +''' Source: the source range of cells as a string +''' Destination: the destination of the moved range of cells, as a string +''' If given as a range of cells, the destination will be reduced to its top-left cell +''' Returns: +''' A string representing the modified range of cells +''' The modified area depends only on the size of the source area +''' Examples: +''' oDoc.MoveRange("SheetX.A1:F10", "SheetY.C5") + +Dim sMove As String ' Return value +Dim oSource As Object ' Alias of Source to avoid "Object variable not set" run-time error +Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim oSelect As Object ' Current selection in source +Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable +Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges +Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress +Dim i As Long + +Const cstThisSub = "SFDocuments.Calc.MoveRange" +Const cstSubArgs = "Source, Destination" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sMove = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _Validate(Source, "Source", V_STRING) Then GoTo Finally + If Not _Validate(Destination, "Destination", V_STRING) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Source).XCellRange.RangeAddress + Set oDestRange = _ParseAddress(Destination) + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = New com.sun.star.table.CellAddress + With oDestAddress + oDestCell.Sheet = .Sheet + oDestCell.Column = .StartColumn + oDestCell.Row = .StartRow + End With + oDestRange.XSpreadsheet.moveRange(oDestCell, oSourceAddress) + + With oSourceAddress + sMove = _Offset(Destination, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName + End With + +Finally: + MoveRange = sMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.MoveRange + +REM ----------------------------------------------------------------------------- +Public Function MoveSheet(Optional ByVal SheetName As Variant _ + , Optional ByVal BeforeSheet As Variant _ + ) As Boolean +''' Move a sheet before an existing sheet or at the end of the list of sheets +''' Args: +''' SheetName: The name of the sheet to move +''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to move the sheet +''' Returns: +''' True if the sheet could be moved successfully +''' Examples: +''' oDoc.MoveSheet("SheetX", "SheetY") + +Dim bMove As Boolean ' Return value +Dim vSheets As Variant ' List of existing sheets +Dim lSheetIndex As Long ' Index of a sheet +Const cstThisSub = "SFDocuments.Calc.MoveSheet" +Const cstSubArgs = "SheetName, [BeforeSheet=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMove = False + +Check: + If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally + End If + vSheets = _Component.getSheets.getElementNames() + +Try: + If VarType(BeforeSheet) = V_STRING Then + lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet) + Else + lSheetIndex = BeforeSheet - 1 + If lSheetIndex < 0 Then lSheetIndex = 0 + If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1 + End If + _Component.getSheets.MoveByName(SheetName, lSheetIndex) + bMove = True + +Finally: + MoveSheet = bMove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.MoveSheet + +REM ----------------------------------------------------------------------------- +Public Function Offset(Optional ByRef Range As Variant _ + , Optional ByVal Rows As Variant _ + , Optional ByVal Columns As Variant _ + , Optional ByVal Height As Variant _ + , Optional ByVal Width As Variant _ + ) As String +''' Returns a new range offset by a certain number of rows and columns from a given range +''' Args: +''' Range : the range, as a string, from which the function searches for the new range +''' Rows : the number of rows by which the reference was corrected up (negative value) or down. +''' Use 0 (default) to stay in the same row. +''' Columns : the number of columns by which the reference was corrected to the left (negative value) or to the right. +''' Use 0 (default) to stay in the same column +''' Height : the vertical height for an area that starts at the new reference position. +''' Default = no vertical resizing +''' Width : the horizontal width for an area that starts at the new reference position. +''' Default - no horizontal resizing +''' Arguments Rows and Columns must not lead to zero or negative start row or column. +''' Arguments Height and Width must not lead to zero or negative count of rows or columns. +''' Returns: +''' A new range as a string +''' Exceptions: +''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries +''' Examples: +''' oDoc.Offset("A1", 2, 2) ' "'SheetX'.$C$3" (A1 moved by two rows and two columns down) +''' oDoc.Offset("A1", 2, 2, 5, 6) ' "'SheetX'.$C$3:$H$7" + +Dim sOffset As String ' Return value +Dim oAddress As Object ' Alias of Range +Const cstThisSub = "SFDocuments.Calc.Offset" +Const cstSubArgs = "Range, [Rows=0], [Columns=0], [Height], [Width]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sOffset = "" + +Check: + If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 + If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 + If IsMissing(Height) Or IsEmpty(Height) Then Height = 0 + If IsMissing(Width) Or IsEmpty(Width) Then Width = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + ' Define the new range string + Set oAddress = _Offset(Range, Rows, Columns, Height, Width) + sOffset = oAddress.RangeName + +Finally: + Offset = sOffset + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.Offset + +REM ----------------------------------------------------------------------------- +Public Function OpenRangeSelector(Optional ByVal Title As Variant _ + , Optional ByVal Selection As Variant _ + , Optional ByVal SingleCell As Variant _ + , Optional ByVal CloseAfterSelect As Variant _ + ) As String +''' Activates the Calc document, opens a non-modal dialog with a text box, +''' let the user make a selection in the current or another sheet and +''' returns the selected area as a string. +''' This method does not change the current selection. +''' Args: +''' Title: the title to display on the top of the dialog +''' Selection: a default preselection as a String. When absent, the first element of the +''' current selection is preselected. +''' SingleCell: When True, only a single cell may be selected. Default = False +''' CloseAfterSelect: When True (default-, the dialog is closed immediately after +''' the selection. When False, the user may change his/her mind and must close +''' the dialog manually. +''' Returns: +''' The selected range as a string, or the empty string when the user cancelled the request (close window button) +''' Exceptions: +''' Examples: +''' Dim sSelect As String, vValues As Variant +''' sSelect = oDoc.OpenRangeSelector("Select a range ...") +''' If sSelect = "" Then Exit Function +''' vValues = oDoc.GetValue(sSelect) + +Dim sSelector As String ' Return value +Dim vPropertyValues As Variant ' Array of com.sun.star.beans.PropertyValue +Dim oSelection As Object ' The current selection before opening the selector +Dim oAddress As Object ' Preselected address as _Address + +Const cstThisSub = "SFDocuments.Calc.OpenRangeSelector" +Const cstSubArgs = "[Title=""""], [Selection=""~""], [SingleCell=False], [CloseAfterSelect=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSelector = "" + +Check: + If IsMissing(Title) Or IsEmpty(Title) Then Title = "" + If IsMissing(Selection) Or IsEmpty(Selection) Then Selection = "~" + If IsMissing(SingleCell) Or IsEmpty(SingleCell) Then SingleCell = False + If IsMissing(CloseAfterSelect) Or IsEmpty(CloseAfterSelect) Then CloseAfterSelect = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Title, "Title", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Selection, "Selection", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SingleCell, "SingleCell", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(CloseAfterSelect, "CloseAfterSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + ' Save the current selections + Set oSelection = _Component.CurrentController.getSelection() + + ' Process preselection and select its containing sheet + Set oAddress = _ParseAddress(Selection) + Activate(oAddress.SheetName) + + ' Build arguments array and execute the dialog box + With ScriptForge.SF_Utils + vPropertyValues = Array( _ + ._MakePropertyValue("Title", Title) _ + , ._MakePropertyValue("CloseOnMouseRelease", CloseAfterSelect) _ + , ._MakePropertyValue("InitialValue", oAddress.XCellRange.AbsoluteName) _ + , ._MakePropertyValue("SingleCellMode", SingleCell) _ + ) + End With + sSelector = SF_DocumentListener.RunRangeSelector(_Component, vPropertyValues) + + ' Restore the saved selections + _RestoreSelections(_Component, oSelection) + +Finally: + OpenRangeSelector = sSelector + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.OpenRangeSelector + +REM ----------------------------------------------------------------------------- +Public Function Printf(Optional ByVal InputStr As Variant _ + , Optional ByVal Range As Variant _ + , Optional ByVal TokenCharacter As Variant _ + ) As String +''' Returns the input string after substitution of its tokens by +''' their values in the given range +''' This method is usually used in combination with SetFormula() +''' The accepted tokens are: +''' - %S The sheet name containing the range, including single quotes when necessary +''' - %R1 The row number of the topleft part of the range +''' - %C1 The column letter of the topleft part of the range +''' - %R2 The row number of the bottomright part of the range +''' - %C2 The column letter of the bottomright part of the range +''' Args: +''' InputStr: usually a Calc formula or a part of a formula, but may be any string +''' Range: the range, as a string from which the values of the tokens are derived +''' TokenCharacter: the character identifying tokens. Default = "%". +''' Double the TokenCharacter to not consider it as a token. +''' Returns: +''' The input string after substitution of the contained tokens +''' Exceptions: +''' Examples: +''' Assume we have in A1:E10 a matrix of numbers. To obtain the sum by row in F1:F10 ... +''' Dim range As String, formula As String +''' range = "$A$1:$E$10") +''' formula = "=SUM($%C1%R1:$%C2%R1)" ' "=SUM($A1:$E1)", note the relative references +''' oDoc.SetFormula("$F$1:$F$10", formula) +''' 'F1 will contain =Sum($A1:$E1) +''' 'F2 =Sum($A2:$E2) +''' ' ... + +Dim sPrintf As String ' Return value +Dim vSubstitute As Variants ' Array of strings representing the token values +Dim oAddress As Object ' A range as an _Address object +Dim sSheetName As String ' The %S token value +Dim sC1 As String ' The %C1 token value +Dim sR1 As String ' The %R1 token value +Dim sC2 As String ' The %C2 token value +Dim sR2 As String ' The %R2 token value +Dim i As Long +Const cstPseudoToken = "@#@" + +Const cstThisSub = "SFDocuments.Calc.Printf" +Const cstSubArgs = "InputStr, Range, TokenCharacter=""%""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sPrintf = "" + +Check: + If IsMissing(TokenCharacter) Or IsEmpty(TokenCharacter) Then TokenCharacter = "%" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TokenCharacter, "TokenCharacter", V_STRING) Then GoTo Finally + End If + +Try: + ' Define the token values + Set oAddress = _ParseAddress(Range) + With oAddress.XCellRange + sC1 = _GetColumnName(.RangeAddress.StartColumn + 1) + sR1 = CStr(.RangeAddress.StartRow + 1) + sC2 = _GetColumnName(.RangeAddress.EndColumn + 1) + sR2 = CStr(.RangeAddress.EndRow + 1) + sSheetName = _QuoteSheetName(oAddress.XSpreadsheet.Name) + End With + + ' Substitute tokens by their values + sPrintf = ScriptForge.SF_String.ReplaceStr(InputStr _ + , Array(TokenCharacter & TokenCharacter _ + , TokenCharacter & "R1" _ + , TokenCharacter & "C1" _ + , TokenCharacter & "R2" _ + , TokenCharacter & "C2" _ + , TokenCharacter & "S" _ + , cstPseudoToken _ + ) _ + , Array(cstPseudoToken _ + , sR1 _ + , sC1 _ + , sR2 _ + , sC2 _ + , sSheetName _ + , TokenCharacter _ + ) _ + ) + +Finally: + Printf = sPrintf + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.Printf + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal SheetName As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + ) As Boolean +''' Send the content of the given sheet to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' Args: +''' SheetName: the sheet to print. Default = the active sheet +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("SheetX", "1-4;10;15-18", Copies := 2) + +Dim bPrint As Boolean ' Return value +Dim oSheet As Object ' SheetName as a reference + +Const cstThisSub = "SFDocuments.Calc.PrintOut" +Const cstSubArgs = "[SheetName=""~""], [Pages=""""], [Copies=1]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "" + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True, True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + If SheetName = "~" Then SheetName = "" + ' Make given sheet active + If Len(SheetName) > 0 Then + With _Component + Set oSheet = .getSheets.getByName(SheetName) + Set .CurrentController.ActiveSheet = oSheet + End With + End If + + bPrint = [_Super].PrintOut(Pages, Copies, _Component) + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Calc class as an array + + Properties = Array( _ + "CurrentSelection" _ + , "CustomProperties" _ + , "Description" _ + , "DocumentProperties" _ + , "DocumentType" _ + , "ExportFilters" _ + , "FirstCell" _ + , "FirstColumn" _ + , "FirstRow" _ + , "Height" _ + , "ImportFilters" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw" _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "Keywords" _ + , "LastCell" _ + , "LastColumn" _ + , "LastRow" _ + , "Range" _ + , "Readonly" _ + , "Region" _ + , "Sheet" _ + , "SheetName" _ + , "Sheets" _ + , "Subject" _ + , "Title" _ + , "Width" _ + , "XCellRange" _ + , "XComponent" _ + , "XSheetCellCursor" _ + , "XSpreadsheet" _ + ) + +End Function ' SFDocuments.SF_Calc.Properties + +REM ----------------------------------------------------------------------------- +Public Function RemoveSheet(Optional ByVal SheetName As Variant) As Boolean +''' Remove an existing sheet from the document +''' Args: +''' SheetName: The name of the sheet to remove +''' Returns: +''' True if the sheet could be removed successfully +''' Examples: +''' oDoc.RemoveSheet("SheetX") + +Dim bRemove As Boolean ' Return value +Const cstThisSub = "SFDocuments.Calc.RemoveSheet" +Const cstSubArgs = "SheetName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRemove = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + End If + +Try: + _Component.getSheets.RemoveByName(SheetName) + bRemove = True + +Finally: + RemoveSheet = bRemove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.RemoveSheet + +REM ----------------------------------------------------------------------------- +Public Function RenameSheet(Optional ByVal SheetName As Variant _ + , Optional ByVal NewName As Variant _ + ) As Boolean +''' Rename a specified sheet +''' Args: +''' SheetName: The name of the sheet to rename +''' NewName: Must not exist +''' Returns: +''' True if the sheet could be renamed successfully +''' Exceptions: +''' DUPLICATESHEETERROR A sheet with the given name exists already +''' Examples: +''' oDoc.RenameSheet("SheetX", "SheetY") + +Dim bRename As Boolean ' Return value +Const cstThisSub = "SFDocuments.Calc.RenameSheet" +Const cstSubArgs = "SheetName, NewName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRename = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally + If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally + End If + +Try: + _Component.getSheets.getByName(SheetName).setName(NewName) + bRename = True + +Finally: + RenameSheet = bRename + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.RenameSheet + +REM ----------------------------------------------------------------------------- +Public Function SetArray(Optional ByVal TargetCell As Variant _ + , Optional ByRef Value As Variant _ + ) As String +''' Set the given (array of) values starting from the target cell +''' The updated area expands itself from the target cell or from the top-left corner of the given range +''' as far as determined by the size of the input Value. +''' Vectors are always expanded vertically +''' Args: +''' TargetCell : the cell or the range as a string that should receive a new value +''' Value: a scalar, a vector or an array with the new values +''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell +''' Returns: +''' A string representing the updated range +''' Exceptions: +''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries +''' Examples: +''' oDoc.SetArray("SheetX.A1", SF_Array.RangeInit(1, 1000)) + +Dim sSet As String ' Return value +Dim oSet As Object ' _Address alias of sSet +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.SetArray" +Const cstSubArgs = "TargetCell, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally + If IsArray(Value) Then + If Not ScriptForge.SF_Utils._ValidateArray(Value, "Value") Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(Value, "Value") Then GoTo Finally + End If + End If + +Try: + ' Convert argument to data array and derive new range from its size + vDataArray = _ConvertToDataArray(Value) + If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally + Set oSet = _Offset(TargetCell, 0, 0, plHeight := UBound(vDataArray) + 1, plWidth := UBound(vDataArray(0)) + 1) ' +1 : vDataArray is zero-based + With oSet + .XCellRange.setDataArray(vDataArray) + sSet = .RangeName + End With + +Finally: + SetArray = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetArray + +REM ----------------------------------------------------------------------------- +Public Function SetCellStyle(Optional ByVal TargetRange As Variant _ + , Optional ByVal Style As Variant _ + ) As String +''' Apply the given cell style in the given range +''' The full range is updated and the remainder of the sheet is left untouched +''' If the cell style does not exist, an error is raised +''' Args: +''' TargetRange : the range as a string that should receive a new cell style +''' Style: the style name as a string +''' Returns: +''' A string representing the updated range +''' Examples: +''' oDoc.SetCellStyle("A1:F1", "Heading 2") + +Dim sSet As String ' Return value +Dim oAddress As _Address ' Alias of TargetRange +Dim oStyleFamilies As Object ' com.sun.star.container.XNameAccess +Dim vStyles As Variant ' Array of existing cell styles +Const cstStyle = "CellStyles" +Const cstThisSub = "SFDocuments.Calc.SetCellStyle" +Const cstSubArgs = "TargetRange, Style" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally + Set oStyleFamilies = _Component.StyleFamilies + If oStyleFamilies.hasByName(cstStyle) Then vStyles = oStyleFamilies.getByName(cstStyle).getElementNames() Else vStyles = Array() + If Not ScriptForge.SF_Utils._Validate(Style, "Style", V_STRING, vStyles) Then GoTo Finally + End If + +Try: + Set oAddress = _ParseAddress(TargetRange) + With oAddress + .XCellRange.CellStyle = Style + sSet = .RangeName + End With + +Finally: + SetCellStyle = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetCellStyle + +REM ----------------------------------------------------------------------------- +Public Function SetFormula(Optional ByVal TargetRange As Variant _ + , Optional ByRef Formula As Variant _ + ) As String +''' Set the given (array of) formulae in the given range +''' The full range is updated and the remainder of the sheet is left untouched +''' If the given formula is a string: +''' the unique formula is pasted across the whole range with adjustment of the relative references +''' Otherwise +''' If the size of Formula < the size of Range, then the other cells are emptied +''' If the size of Formula > the size of Range, then Formula is only partially copied +''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row +''' Args: +''' TargetRange : the range as a string that should receive a new Formula +''' Formula: a scalar, a vector or an array with the new formula(e) as strings for each cell of the range. +''' Returns: +''' A string representing the updated range +''' Examples: +''' oDoc.SetFormula("A1", "=A2") +''' oDoc.SetFormula("A1:F1", Array("=A2", "=B2", "=C2+10")) ' Horizontal vector, partially empty +''' oDoc.SetFormula("A1:D2", "=E1") ' D2 contains the formula "=H2" + +Dim sSet As String ' Return value.XSpreadsheet.Name) +Dim oAddress As Object ' Alias of TargetRange +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.SetFormula" +Const cstSubArgs = "TargetRange, Formula" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally + If IsArray(Formula) Then + If Not ScriptForge.SF_Utils._ValidateArray(Formula, "Formula", 0, V_STRING) Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(Formula, "Formula", V_STRING) Then GoTo Finally + End If + End If + +Try: + Set oAddress = _ParseAddress(TargetRange) + With oAddress + If IsArray(Formula) Then + ' Convert to data array and limit its size to the size of the initial range + vDataArray = _ConvertToDataArray(Formula, .Height - 1, .Width - 1) + If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally + .XCellRange.setFormulaArray(vDataArray) + Else + With .XCellRange + ' Store formula in top-left cell and paste it along the whole range + .getCellByPosition(0, 0).setFormula(Formula) + .fillSeries(com.sun.star.sheet.FillDirection.TO_BOTTOM, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0) + .fillSeries(com.sun.star.sheet.FillDirection.TO_RIGHT, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0) + End With + End If + sSet = .RangeName + End With + +Finally: + SetFormula = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetFormula + +REM ----------------------------------------------------------------------------- +Private Function SetProperty(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Calc.set" & psProperty + If IsMissing(pvValue) Then pvValue = Empty + 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("CurrentSelection") + CurrentSelection = pvValue + Case UCase("CustomProperties") + CustomProperties = pvValue + Case UCase("Description") + Description = pvValue + Case UCase("Keywords") + Keywords = pvValue + Case UCase("Subject") + Subject = pvValue + Case UCase("Title") + Title = pvValue + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Calc.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SetValue(Optional ByVal TargetRange As Variant _ + , Optional ByRef Value As Variant _ + ) As String +''' Set the given value in the given range +''' The full range is updated and the remainder of the sheet is left untouched +''' If the size of Value < the size of Range, then the other cells are emptied +''' If the size of Value > the size of Range, then Value is only partially copied +''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row +''' Args: +''' TargetRange : the range as a string that should receive a new value +''' Value: a scalar, a vector or an array with the new values for each cell o.XSpreadsheet.Name)f the range. +''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell +''' Returns: +''' A string representing the updated range +''' Examples: +''' oDoc.SetValue("A1", 2) +''' oDoc.SetValue("A1:F1", Array(1, 2, 3)) ' Horizontal vector, partially empty +''' oDoc.SetValue("A1:D2", SF_Array.AppendRow(Array(1, 2, 3, 4), Array(5, 6, 7, 8))) + +Dim sSet As String ' Return value +Dim oAddress As Object ' Alias of TargetRange +Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property +Const cstThisSub = "SFDocuments.Calc.SetValue" +Const cstSubArgs = "TargetRange, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSet = "" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally + If IsArray(Value) Then + If Not ScriptForge.SF_Utils._ValidateArray(Value, "Value") Then GoTo Finally + Else + If Not ScriptForge.SF_Utils._Validate(Value, "Value") Then GoTo Finally + End If + End If + +Try: + Set oAddress = _ParseAddress(TargetRange) + With oAddress + ' Convert to data array and limit its size to the size of the initial range + vDataArray = _ConvertToDataArray(Value, .Height - 1, .Width - 1) + If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally + .XCellRange.setDataArray(vDataArray) + sSet = .RangeName + End With + +Finally: + SetValue = sSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SetValue + +REM ----------------------------------------------------------------------------- +Public Function ShiftDown(Optional ByVal Range As Variant _ + , Optional ByVal WholeRow As Variant _ + , Optional ByVal Rows As Variant _ + ) As String +''' Move a specified range and all cells below in the same columns downwards by inserting empty cells +''' The inserted cells can span whole rows or be limited to the width of the range +''' The height of the inserted area is provided by the Rows argument +''' Nothing happens if the range shift crosses one of the edges of the worksheet +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range above which cells have to be inserted, as a string +''' WholeRow: when True (default = False), insert whole rows +''' Rows: the height of the area to insert. Default = the height of the Range argument +''' Returns: +''' A string representing the new location of the initial range +''' Examples: +''' newrange = oDoc.ShiftDown("SheetX.A1:F10") ' "$SheetX.$A$11:$F$20" +''' newrange = oDoc.ShiftDown("SheetX.A1:F10", Rows := 3) ' "$SheetX.$A$4:$F$13" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lHeight As Long ' Range height +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftDown" +Const cstSubArgs = "Range, [WholeRow=False], [Rows]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False + If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Manage the height of the area to shift + ' The insertCells() method inserts a number of rows equal to the height of the cell range to shift + lHeight = .Height + If Rows <= 0 Then Rows = lHeight + If _LastCell(.XSpreadsheet)(1) + Rows > MAXROWS Then GoTo Catch + If Rows <> lHeight Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, Rows, 0).XCellRange.RangeAddress + Else + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the shift mode + With com.sun.star.sheet.CellInsertMode + If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .DOWN + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.insertCells(oShiftAddress, lShiftMode) + + ' Determine the receiving area + sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftDown = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftDown + +REM ----------------------------------------------------------------------------- +Public Function ShiftLeft(Optional ByVal Range As Variant _ + , Optional ByVal WholeColumn As Variant _ + , Optional ByVal Columns As Variant _ + ) As String +''' Delete the leftmost columns of a specified range and move all cells at their right leftwards +''' The deleted cells can span whole columns or be limited to the height of the range +''' The width of the deleted area is provided by the Columns argument +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeColumn: when True (default = False), erase whole columns +''' Columns: the width of the area to delete. +''' Default = the width of the Range argument, it is also its maximum value +''' Returns: +''' A string representing the location of the remaining part of the initial range, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.ShiftLeft("SheetX.G1:L10") ' """ +''' newrange = oDoc.ShiftLeft("SheetX.G1:L10", Columns := 3) ' "$SheetX.$G$1:$I$10" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lWidth As Long ' Range width +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftLeft" +Const cstSubArgs = "Range, [WholeColumn=False], [Columns]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False + If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time + + With oSourceAddress + + ' Manage the width of the area to delete + ' The removeRange() method erases a number of columns equal to the width of the cell range to delete + lWidth = .Width + If Columns <= 0 Then Columns = lWidth + If Columns < lWidth Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, 0, Columns).XCellRange.RangeAddress + Else ' Columns is capped at the range width + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the Delete mode + With com.sun.star.sheet.CellDeleteMode + If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .LEFT + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.removeRange(oShiftAddress, lShiftMode) + + ' Determine the remaining area + If Columns < lWidth Then sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftLeft = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftLeft + +REM ----------------------------------------------------------------------------- +Public Function ShiftRight(Optional ByVal Range As Variant _ + , Optional ByVal WholeColumn As Variant _ + , Optional ByVal Columns As Variant _ + ) As String +''' Move a specified range and all next cells in the same rows to the right by inserting empty cells +''' The inserted cells can span whole columns or be limited to the height of the range +''' The width of the inserted area is provided by the Columns argument +''' Nothing happens if the range shift crosses one of the edges of the worksheet +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range before which cells have to be inserted, as a string +''' WholeColumn: when True (default = False), insert whole columns +''' Columns: the width of the area to insert. Default = the width of the Range argument +''' Returns: +''' A string representing the new location of the initial range +''' Examples: +''' newrange = oDoc.ShiftRight("SheetX.A1:F10") ' "$SheetX.$G$1:$L$10" +''' newrange = oDoc.ShiftRight("SheetX.A1:F10", Columns := 3) ' "$SheetX.$D$1:$I$10" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lWidth As Long ' Range width +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftRight" +Const cstSubArgs = "Range, [WholeColumn=False], [Columns]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False + If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + + With oSourceAddress + + ' Manage the width of the area to Shift + ' The insertCells() method inserts a number of columns equal to the width of the cell range to Shift + lWidth = .Width + If Columns <= 0 Then Columns = lWidth + If _LastCell(.XSpreadsheet)(0) + Columns > MAXCOLS Then GoTo Catch + If Columns <> lWidth Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, 0, Columns).XCellRange.RangeAddress + Else + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the Shift mode + With com.sun.star.sheet.CellInsertMode + If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .RIGHT + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.insertCells(oShiftAddress, lShiftMode) + + ' Determine the receiving area + sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftRight = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftRight + +REM ----------------------------------------------------------------------------- +Public Function ShiftUp(Optional ByVal Range As Variant _ + , Optional ByVal WholeRow As Variant _ + , Optional ByVal Rows As Variant _ + ) As String +''' Delete the topmost rows of a specified range and move all cells below upwards +''' The deleted cells can span whole rows or be limited to the width of the range +''' The height of the deleted area is provided by the Rows argument +''' The execution of the method has no effect on the current selection +''' Args: +''' Range: the range in which cells have to be erased, as a string +''' WholeRow: when True (default = False), erase whole rows +''' Rows: the height of the area to delete. +''' Default = the height of the Range argument, it is also its maximum value +''' Returns: +''' A string representing the location of the remaining part of the initial range, +''' or the zero-length string if the whole range has been deleted +''' Examples: +''' newrange = oDoc.ShiftUp("SheetX.G1:L10") ' "" +''' newrange = oDoc.ShiftUp("SheetX.G1:L10", Rows := 3) ' "$SheetX.$G$1:$I$10" + +Dim sShift As String ' Return value +Dim oSourceAddress As Object ' Alias of Range as _Address +Dim lHeight As Long ' Range height +Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right height +Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values + +Const cstThisSub = "SFDocuments.Calc.ShiftUp" +Const cstSubArgs = "Range, [WholeRow=False], [Rows]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sShift = "" + +Check: + If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False + If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + Set oSourceAddress = _ParseAddress(Range) + Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time + + With oSourceAddress + + ' Manage the height of the area to delete + ' The removeRange() method erases a number of rows equal to the height of the cell range to delete + lHeight = .Height + If Rows <= 0 Then Rows = lHeight + If Rows < lHeight Then + Set oShiftAddress = _Offset(oSourceAddress, 0, 0, Rows, 0).XCellRange.RangeAddress + Else ' Rows is capped at the range height + Set oShiftAddress = .XCellRange.RangeAddress + End If + + ' Determine the Delete mode + With com.sun.star.sheet.CellDeleteMode + If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .UP + End With + + ' Move the cells as requested. This modifies .XCellRange + .XSpreadsheet.removeRange(oShiftAddress, lShiftMode) + + ' Determine the remaining area + If Rows < lHeight Then sShift = .XCellRange.AbsoluteName + + End With + +Finally: + ShiftUp = sShift + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + ' When error, return the original range + If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName + GoTo Finally +End Function ' SFDocuments.SF_Calc.ShiftUp + +REM ----------------------------------------------------------------------------- +Public Function SortRange(Optional ByVal Range As Variant _ + , Optional ByVal SortKeys As Variant _ + , Optional ByVal SortOrder As Variant _ + , Optional ByVal DestinationCell As Variant _ + , Optional ByVal ContainsHeader As Variant _ + , Optional ByVal CaseSensitive As Variant _ + , Optional ByVal SortColumns As Variant _ + ) As Variant +''' Sort the given range on maximum 3 columns/rows. The sorting order may vary by column/row +''' Args: +''' Range: the range to sort as a string +''' SortKeys: a scalar (if 1 column/row) or an array of column/row numbers starting from 1 +''' SortOrder: a scalar or an array of strings: "ASC" or "DESC" +''' Each item is paired with the corresponding item in SortKeys +''' If the SortOrder array is shorter than SortKeys, the remaining keys are sorted +''' in ascending order +''' DestinationCell: the destination of the sorted range of cells, as a string +''' If given as range, the destination will be reduced to its top-left cell +''' By default, Range is overwritten with its sorted content +''' ContainsHeader: when True, the first row/column is not sorted. Default = False +''' CaseSensitive: only for string comparisons, default = False +''' SortColumns: when True, the columns are sorted from left to right +''' Default = False: rows are sorted from top to bottom. +''' Returns: +''' The modified range of cells as a string +''' Example: +''' oDoc.SortRange("A2:J200", Array(1, 3), , Array("ASC", "DESC"), CaseSensitive := True) +''' ' Sort on columns A (ascending) and C (descending) + +Dim sSort As String ' Return value +Dim oRangeAddress As _Address ' Parsed range +Dim oRange As Object ' com.sun.star.table.XCellRange +Dim oDestRange As Object ' Destination as a range +Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress +Dim oDestCell As Object ' com.sun.star.table.CellAddress +Dim vSortDescriptor As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vSortFields As Variant ' Array of com.sun.star.table.TableSortField +Dim sOrder As String ' Item in SortOrder +Dim i As Long +Const cstThisSub = "SFDocuments.Calc.SortRange" +Const cstSubArgs = "Range, SortKeys, [TargetRange=""""], [SortOrder=""ASC""], [DestinationCell=""""], [ContainsHeader=False], [CaseSensitive=False], [SortColumns=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + sSort = "" + +Check: + If IsMissing(SortKeys) Or IsEmpty(SortKeys) Then + SortKeys = Array(1) + ElseIf Not IsArray(SortKeys) Then + SortKeys = Array(SortKeys) + End If + If IsMissing(DestinationCell) Or IsEmpty(DestinationCell) Then DestinationCell = "" + If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then + SortOrder = Array("ASC") + ElseIf Not IsArray(SortOrder) Then + SortOrder = Array(SortOrder) + End If + If IsMissing(ContainsHeader) Or IsEmpty(ContainsHeader) Then ContainsHeader = False + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If IsMissing(SortColumns) Or IsEmpty(SortColumns) Then SortColumns = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateArray(SortKeys, "SortKeys", 1, V_NUMERIC, True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateArray(SortOrder, "SortOrder", 1, V_STRING, True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ContainsHeader, "ContainsHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SortColumns, "SortColumns", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + Set oRangeAddress = _ParseAddress(Range) + If Len(DestinationCell) > 0 Then Set oDestRange = _ParseAddress(DestinationCell) + +Try: + ' Initialize the sort descriptor + Set oRange = oRangeAddress.XCellRange + vSortDescriptor = oRange.createSortDescriptor + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsSortColumns", SortColumns) + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "ContainsHeader", ContainsHeader) + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "BindFormatsToContent", True) + If Len(DestinationCell) = 0 Then + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", False) + Else + Set oDestAddress = oDestRange.XCellRange.RangeAddress + Set oDestCell = New com.sun.star.table.CellAddress + With oDestAddress + oDestCell.Sheet = .Sheet + oDestCell.Column = .StartColumn + oDestCell.Row = .StartRow + End With + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", True) + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", oDestCell) + End If + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsUserListEnabled", False) + + ' Define the sorting keys + vSortFields = Array() + ReDim vSortFields(0 To UBound(SortKeys)) + For i = 0 To UBound(SortKeys) + vSortFields(i) = New com.sun.star.table.TableSortField + If i > UBound(SortOrder) Then sOrder = "" Else sOrder = SortOrder(i) + If Len(sOrder) = 0 Then sOrder = "ASC" + With vSortFields(i) + .Field = SortKeys(i) - 1 + .IsAscending = ( UCase(sOrder) = "ASC" ) + .IsCaseSensitive = CaseSensitive + End With + Next i + + ' Associate the keys and the descriptor, and sort + vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "SortFields", vSortFields) + oRange.sort(vSortDescriptor) + + ' Compute the changed area + If Len(DestinationCell) = 0 Then + sSort = oRangeAddress.RangeName + Else + With oRangeAddress + sSort = _Offset(oDestRange, 0, 0, .Height, .Width).RangeName + End With + End If + +Finally: + SortRange = sSort + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc.SortRange + +REM ======================================================= SUPERCLASS PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CustomProperties() As Variant + CustomProperties = [_Super].GetProperty("CustomProperties") +End Property ' SFDocuments.SF_Calc.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) + [_Super].CustomProperties = pvCustomProperties +End Property ' SFDocuments.SF_Calc.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant + Description = [_Super].GetProperty("Description") +End Property ' SFDocuments.SF_Calc.Description + +REM ----------------------------------------------------------------------------- +Property Let Description(Optional ByVal pvDescription As Variant) + [_Super].Description = pvDescription +End Property ' SFDocuments.SF_Calc.Description + +REM ----------------------------------------------------------------------------- +Property Get DocumentProperties() As Variant + DocumentProperties = [_Super].GetProperty("DocumentProperties") +End Property ' SFDocuments.SF_Calc.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String + DocumentType = [_Super].GetProperty("DocumentType") +End Property ' SFDocuments.SF_Calc.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get ExportFilters() As Variant + ExportFilters = [_Super].GetProperty("ExportFilters") +End Property ' SFDocuments.SF_Calc.ExportFilters + +REM ----------------------------------------------------------------------------- +Property Get ImportFilters() As Variant + ImportFilters = [_Super].GetProperty("ImportFilters") +End Property ' SFDocuments.SF_Calc.ImportFilters + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = [_Super].GetProperty("IsBase") +End Property ' SFDocuments.SF_Calc.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = [_Super].GetProperty("IsCalc") +End Property ' SFDocuments.SF_Calc.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = [_Super].GetProperty("IsDraw") +End Property ' SFDocuments.SF_Calc.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = [_Super].GetProperty("IsImpress") +End Property ' SFDocuments.SF_Calc.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = [_Super].GetProperty("IsMath") +End Property ' SFDocuments.SF_Calc.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = [_Super].GetProperty("IsWriter") +End Property ' SFDocuments.SF_Calc.IsWriter + +REM ----------------------------------------------------------------------------- +Property Get Keywords() As Variant + Keywords = [_Super].GetProperty("Keywords") +End Property ' SFDocuments.SF_Calc.Keywords + +REM ----------------------------------------------------------------------------- +Property Let Keywords(Optional ByVal pvKeywords As Variant) + [_Super].Keywords = pvKeywords +End Property ' SFDocuments.SF_Calc.Keywords + +REM ----------------------------------------------------------------------------- +Property Get Readonly() As Variant + Readonly = [_Super].GetProperty("Readonly") +End Property ' SFDocuments.SF_Calc.Readonly + +REM ----------------------------------------------------------------------------- +Property Get Subject() As Variant + Subject = [_Super].GetProperty("Subject") +End Property ' SFDocuments.SF_Calc.Subject + +REM ----------------------------------------------------------------------------- +Property Let Subject(Optional ByVal pvSubject As Variant) + [_Super].Subject = pvSubject +End Property ' SFDocuments.SF_Calc.Subject + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant + Title = [_Super].GetProperty("Title") +End Property ' SFDocuments.SF_Calc.Title + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) + [_Super].Title = pvTitle +End Property ' SFDocuments.SF_Calc.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant + XComponent = [_Super].GetProperty("XComponent") +End Property ' SFDocuments.SF_Calc.XComponent + +REM ========================================================== SUPERCLASS METHODS + +REM ----------------------------------------------------------------------------- +'Public Function Activate() As Boolean +' Activate = [_Super].Activate() +'End Function ' SFDocuments.SF_Calc.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean + CloseDocument = [_Super].CloseDocument(SaveAsk) +End Function ' SFDocuments.SF_Calc.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object + Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) +End Function ' SFDocuments.SF_Calc.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function ExportAsPDF(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal Watermark As Variant _ + ) As Boolean + ExportAsPDF = [_Super].ExportAsPDF(FileName, Overwrite, Pages, Password, Watermark) +End Function ' SFDocuments.SF_Calc.ExportAsPDF + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean + RemoveMenu = [_Super].RemoveMenu(MenuHeader) +End Function ' SFDocuments.SF_Calc.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) + [_Super].RunCommand(Command, Args) +End Sub ' SFDocuments.SF_Calc.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean + Save = [_Super].Save() +End Function ' SFDocuments.SF_Calc.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Calc.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Calc.SaveCopyAs + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + ) As Boolean + SetPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat) +End Function ' SFDocuments.SF_Calc.SetPrinter + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _ConvertFromDataArray(ByRef pvDataArray As Variant) As Variant +''' Convert a data array to a scalar, a vector or a 2D array +''' Args: +''' pvDataArray: an array as returned by the XCellRange.getDataArray or .getFormulaArray methods +''' Returns: +''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and/or doubles +''' To convert doubles to dates, use the CDate builtin function + +Dim vArray As Variant ' Return value +Dim lMax1 As Long ' UBound of pvDataArray +Dim lMax2 As Long ' UBound of pvDataArray items +Dim i As Long +Dim j As Long + + vArray = Empty + +Try: + ' Convert the data array to scalar, vector or array + lMax1 = UBound(pvDataArray) + If lMax1 >= 0 Then + lMax2 = UBound(pvDataArray(0)) + If lMax2 >= 0 Then + If lMax1 + lMax2 > 0 Then vArray = Array() + Select Case True + Case lMax1 = 0 And lMax2 = 0 ' Scalar + vArray = pvDataArray(0)(0) + Case lMax1 > 0 And lMax2 = 0 ' Vertical vector + ReDim vArray(0 To lMax1) + For i = 0 To lMax1 + vArray(i) = pvDataArray(i)(0) + Next i + Case lMax1 = 0 And lMax2 > 0 ' Horizontal vector + ReDim vArray(0 To lMax2) + For j = 0 To lMax2 + vArray(j) = pvDataArray(0)(j) + Next j + Case Else ' Array + ReDim vArray(0 To lMax1, 0 To lMax2) + For i = 0 To lMax1 + For j = 0 To lMax2 + vArray(i, j) = pvDataArray(i)(j) + Next j + Next i + End Select + End If + End If + +Finally: + _ConvertFromDataArray = vArray +End Function ' SF_Documents.SF_Calc._ConvertFromDataArray + +REM ----------------------------------------------------------------------------- +Private Function _ConvertToCellValue(ByVal pvItem As Variant) As Variant +''' Convert the argument to a valid Calc cell content + +Dim vCell As Variant ' Return value + +Try: + Select Case ScriptForge.SF_Utils._VarTypeExt(pvItem) + Case V_STRING : vCell = pvItem + Case V_DATE : vCell = CDbl(pvItem) + Case ScriptForge.V_NUMERIC : vCell = CDbl(pvItem) + Case ScriptForge.V_BOOLEAN : vCell = CDbl(Iif(pvItem, 1, 0)) + Case Else : vCell = "" + End Select + +Finally: + _ConvertToCellValue = vCell + Exit Function +End Function ' SF_Documents.SF_Calc._ConvertToCellValue + +REM ----------------------------------------------------------------------------- +Private Function _ConvertToDataArray(ByRef pvArray As Variant _ + , Optional ByVal plRows As Long _ + , Optional ByVal plColumns As Long _ + ) As Variant +''' Create a 2-dimensions nested array (compatible with the ranges .DataArray property) +''' from a scalar, a 1D array or a 2D array +''' Input may be a 1D array of arrays, typically when call issued by a Python script +''' Array items are converted to (possibly empty) strings or doubles +''' Args: +''' pvArray: the input scalar or array. If array, must be 1 or 2D otherwise it is ignored. +''' plRows, plColumns: the upper bounds of the data array +''' If bigger than input array, fill with zero-length strings +''' If smaller than input array, truncate +''' If plRows = 0 and the input array is a vector, the data array is aligned horizontally +''' They are either both present or both absent +''' When absent +''' The size of the output is fully determined by the input array +''' Vectors are aligned vertically +''' Returns: +''' A data array compatible with ranges .DataArray property +''' The output is always an array of nested arrays + +Dim vDataArray() As Variant ' Return value +Dim vVector() As Variant ' A temporary 1D array +Dim vItem As Variant ' A single input item +Dim iDims As Integer ' Number of dimensions of the input argument +Dim lMin1 As Long ' Lower bound (1) of input array +Dim lMax1 As Long ' Upper bound (1) +Dim lMin2 As Long ' Lower bound (2) +Dim lMax2 As Long ' Upper bound (2) +Dim lRows As Long ' Upper bound of vDataArray +Dim lCols As Long ' Upper bound of vVector +Dim bHorizontal As Boolean ' Horizontal vector +Dim bDataArray As Boolean ' Input array is already an array of arrays +Dim i As Long +Dim j As Long + +Const cstEmpty = "" ' Empty cell + + If IsMissing(plRows) Or IsEmpty(plRows) Then plRows = -1 + If IsMissing(plColumns) Or IsEmpty(plColumns) Then plColumns = -1 + + vDataArray = Array() + +Try: + ' Check the input argument and know its boundaries + iDims = ScriptForge.SF_Array.CountDims(pvArray) + If iDims = 0 Or iDims > 2 Then Exit Function + lMin1 = 0 : lMax1 = 0 ' Default values + lMin2 = 0 : lMax2 = 0 + Select Case iDims + Case -1 ' Scalar value + Case 1 + bHorizontal = ( plRows = 0 And plColumns > 0 ) + bDataArray = IsArray(pvArray(0)) + If Not bDataArray Then + If Not bHorizontal Then + lMin1 = LBound(pvArray) : lMax1 = UBound(pvArray) + Else + lMin2 = LBound(pvArray) : lMax2 = UBound(pvArray) + End If + Else + iDims = 2 + lMin1 = LBound(pvArray) : lMax1 = UBound(pvArray) + lMin2 = LBound(pvArray(0)) : lMax2 = UBound(pvArray(0)) + End If + Case 2 + lMin1 = LBound(pvArray, 1) : lMax1 = UBound(pvArray, 1) + lMin2 = LBound(pvArray, 2) : lMax2 = UBound(pvArray, 2) + End Select + + ' Set the output dimensions accordingly + If plRows >= 0 Then ' Dimensions of output are imposed + lRows = plRows + lCols = plColumns + Else ' Dimensions of output determined by input argument + lRows = 0 : lCols = 0 ' Default values + Select Case iDims + Case -1 ' Scalar value + Case 1 ' Vectors are aligned vertically + lRows = lMax1 - lMin1 + Case 2 + lRows = lMax1 - lMin1 + lCols = lMax2 - lMin2 + End Select + End If + ReDim vDataArray(0 To lRows) + + ' Feed the output array row by row, each row being a vector + For i = 0 To lRows + ReDim vVector(0 To lCols) + For j = 0 To lCols + If i > lMax1 - lMin1 Then + vVector(j) = cstEmpty + ElseIf j > lMax2 - lMin2 Then + vVector(j) = cstEmpty + Else + Select Case iDims + Case -1 : vItem = _ConvertToCellValue(pvArray) + Case 1 + If bHorizontal Then + vItem = _ConvertToCellValue(pvArray(j + lMin2)) + Else + vItem = _ConvertToCellValue(pvArray(i + lMin1)) + End If + Case 2 + If bDataArray Then + vItem = _ConvertToCellValue(pvArray(i + lMin1)(j + lMin2)) + Else + vItem = _ConvertToCellValue(pvArray(i + lMin1, j + lMin2)) + End If + End Select + vVector(j) = vItem + End If + vDataArray(i) = vVector + Next j + Next i + +Finally: + _ConvertToDataArray = vDataArray + Exit Function +End Function ' SF_Documents.SF_Calc._ConvertToDataArray + +REM ----------------------------------------------------------------------------- +Private Function _DFunction(ByVal psFunction As String _ + , Optional ByVal Range As Variant _ + ) As Double +''' Apply the given function on all the numeric values stored in the given range +''' Args: +''' Range : the range as a string where to apply the function on +''' Returns: +''' The resulting value as a double + +Dim dblGet As Double ' Return value +Dim oAddress As Object ' Alias of Range +Dim vFunction As Variant ' com.sun.star.sheet.GeneralFunction.XXX +Dim cstThisSub As String : cstThisSub = "SFDocuments.Calc." & psFunction +Const cstSubArgs = "Range" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + dblGet = 0 + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally + End If + +Try: + ' Get the data + Set oAddress = _ParseAddress(Range) + Select Case psFunction + Case "DAvg" : vFunction = com.sun.star.sheet.GeneralFunction.AVERAGE + Case "DCount" : vFunction = com.sun.star.sheet.GeneralFunction.COUNTNUMS + Case "DMax" : vFunction = com.sun.star.sheet.GeneralFunction.MAX + Case "DMin" : vFunction = com.sun.star.sheet.GeneralFunction.MIN + Case "DSum" : vFunction = com.sun.star.sheet.GeneralFunction.SUM + Case Else : GoTo Finally + End Select + dblGet = oAddress.XCellRange.computeFunction(vFunction) + +Finally: + _DFunction = dblGet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Calc._DFunction + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Calc._FileIdent + +REM ----------------------------------------------------------------------------- +Function _GetColumnName(ByVal plColumnNumber As Long) As String +''' Convert a column number (range 1, 2,..1024) into its letter counterpart (range 'A', 'B',..'AMJ'). +''' Args: +''' ColumnNumber: the column number, must be in the interval 1 ... 1024 +''' Returns: +''' a string representation of the column name, in range 'A'..'AMJ' +''' Adapted from a Python function by sundar nataraj +''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter + +Dim sCol As String ' Return value +Dim lDiv As Long ' Intermediate result +Dim lMod As Long ' Result of modulo 26 operation + +Try: + lDiv = plColumnNumber + Do While lDiv > 0 + lMod = (lDiv - 1) Mod 26 + sCol = Chr(65 + lMod) + sCol + lDiv = Int((lDiv - lMod)/26) + Loop + +Finally: + _GetColumnName = sCol +End Function ' SFDocuments.SF_Calc._GetColumnName + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) + +Finally: + _IsStillAlive = bAlive + Exit Function +End Function ' SFDocuments.SF_Calc._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _LastCell(ByRef poSheet As Object) As Variant +''' Returns in an array the coordinates of the last used cell in the given sheet + +Dim oCursor As Object ' Cursor on the cell +Dim oRange As Object ' The used range +Dim vCoordinates(0 To 1) As Long ' Return value: (0) = Column, (1) = Row + +Try: + Set oCursor = poSheet.createCursorByRange(poSheet.getCellRangeByName("A1")) + oCursor.gotoEndOfUsedArea(True) + Set oRange = poSheet.getCellRangeByName(oCursor.AbsoluteName) + + vCoordinates(0) = oRange.RangeAddress.EndColumn + 1 + vCoordinates(1) = oRange.RangeAddress.EndRow + 1 + +Finally: + _LastCell = vCoordinates +End Function ' SFDocuments.SF_Calc._LastCell + +REM ----------------------------------------------------------------------------- +Public Function _Offset(ByRef pvRange As Variant _ + , ByVal plRows As Long _ + , ByVal plColumns As Long _ + , ByVal plHeight As Long _ + , ByVal plWidth As Long _ + ) As Object +''' Returns a new range offset by a certain number of rows and columns from a given range +''' Args: +''' pvRange : the range, as a string or an object, from which the function searches for the new range +''' plRows : the number of rows by which the reference was corrected up (negative value) or down. +''' plColumns : the number of columns by which the reference was corrected to the left (negative value) or to the right. +''' plHeight : the vertical height for an area that starts at the new reference position. +''' plWidth : the horizontal width for an area that starts at the new reference position. +''' Arguments Rows and Columns must not lead to zero or negative start row or column. +''' Arguments Height and Width must not lead to zero or negative count of rows or columns. +''' Returns: +''' A new range as object of type _Address +''' Exceptions: +''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries + +Dim oOffset As Object ' Return value +Dim oAddress As Object ' Alias of Range +Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet +Dim oRange As Object ' com.sun.star.table.XCellRange +Dim oNewRange As Object ' com.sun.star.table.XCellRange +Dim lLeft As Long ' New range coordinates +Dim lTop As Long +Dim lRight As Long +Dim lBottom As Long + + Set oOffset = Nothing + +Check: + If plHeight < 0 Or plWidth < 0 Then GoTo CatchAddress + +Try: + If VarType(pvRange) = V_STRING Then Set oAddress = _ParseAddress(pvRange) Else Set oAddress = pvRange + Set oSheet = oAddress.XSpreadSheet + Set oRange = oAddress.XCellRange.RangeAddress + + + ' Compute and validate new coordinates + With oRange + lLeft = .StartColumn + plColumns + lTop = .StartRow + plRows + lRight = lLeft + Iif(plWidth = 0, .EndColumn - .StartColumn, plWidth - 1) + lBottom = lTop + Iif(plHeight = 0, .EndRow - .StartRow, plHeight - 1) + If lLeft < 0 Or lRight < 0 Or lTop < 0 Or lBottom < 0 _ + Or lLeft > MAXCOLS Or lRight > MAXCOLS _ + Or lTop > MAXROWS Or lBottom > MAXROWS _ + Then GoTo CatchAddress + Set oNewRange = oSheet.getCellRangeByPosition(lLeft, lTop, lRight, lBottom) + End With + + ' Define the new range address + Set oOffset = New _Address + With oOffset + .ObjectType = CALCREFERENCE + .ServiceName = SERVICEREFERENCE + .RawAddress = oNewRange.AbsoluteName + .Component = _Component + .XSpreadsheet = oNewRange.Spreadsheet + .SheetName = .XSpreadsheet.Name + .SheetIndex = .XSpreadsheet.RangeAddress.Sheet + .RangeName = .RawAddress + .XCellRange = oNewRange + .Height = oNewRange.RangeAddress.EndRow - oNewRange.RangeAddress.StartRow + 1 + .Width = oNewRange.RangeAddress.EndColumn - oNewRange.RangeAddress.StartColumn + 1 + End With + +Finally: + Set _Offset = oOffset + Exit Function +Catch: + GoTo Finally +CatchAddress: + ScriptForge.SF_Exception.RaiseFatal(OFFSETADDRESSERROR, "Range", oAddress.RawAddress _ + , "Rows", plRows, "Columns", plColumns, "Height", plHeight, "Width", plWidth _ + , "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SF_Documents.SF_Calc._Offset + +REM ----------------------------------------------------------------------------- +Private Function _ParseAddress(ByVal psAddress As String) As Object +''' Parse and validate a sheet or range reference +''' Syntax to parse: +''' [Sheet].[Range] +''' Sheet => ['][$]sheet['] or document named range or ~ +''' Range => A1:D10, A1, A:D, 10:10 ($ ignored), or sheet named range or ~ +''' Returns: +''' An object of type _Address +''' Exceptions: +''' CALCADDRESSERROR ' Address could not be parsed to a valid address + +Dim oAddress As Object ' Return value +Dim sAddress As String ' Alias of psAddress +Dim lStart As Long ' Position of found regex +Dim sSheet As String ' Sheet component +Dim sRange As String ' Range component +Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets +Dim oNamedRanges As Object ' com.sun.star.sheet.XNamedRanges +Dim oRangeAddress As Object ' Alias for rangeaddress +Dim vLastCell As Variant ' Result of _LastCell() method +Dim oSelect As Object ' Current selection + + ' If psAddress has already been parsed, get the result back + If Not IsNull(_LastParsedAddress) Then + ' Given argument must contain an explicit reference to a sheet + If (InStr(psAddress, "~.") = 0 And InStr(psAddress, ".") > 0 And psAddress = _LastParsedAddress.RawAddress) _ + Or psAddress = _LastParsedAddress.RangeName Then + Set _ParseAddress = _LastParsedAddress + Exit Function + Else + Set _LastParsedAddress = Nothing + End If + End If + + ' Reinitialize a new _Address object + Set oAddress = New _Address + With oAddress + sSheet = "" : sRange = "" + .SheetName = "" : .RangeName = "" + + .ObjectType = CALCREFERENCE + .ServiceName = SERVICEREFERENCE + .RawAddress = psAddress + Set .XSpreadSheet = Nothing : Set .XCellRange = Nothing + + ' Remove leading '$' + If Left(psAddress, 1) = "$" Then sAddress = Mid(psAddress, 2) Else sAddress = psAddress + ' Split in sheet and range components - Check presence of surrounding single quotes or dot + If Left(sAddress, 1) = "'" Then + lStart = 1 + sSheet = ScriptForge.SF_String.FindRegex(sAddress, "^'[^\[\]*?:\/\\]+'") + If lStart = 0 Then GoTo CatchAddress ' Invalid sheet name + If Len(sAddress) > Len(sSheet) + 1 Then + If Mid(sAddress, Len(sSheet) + 1, 1) = "." then sRange = Mid(sAddress, Len(sSheet) + 2) + End If + sSheet = Replace(Replace(sSheet, "$", ""), "'", "") + ElseIf InStr(sAddress, ".") > 0 Then + sSheet = Replace(Split(sAddress, ".")(0), "$", "") + sRange = Replace(Split(sAddress, ".")(1), "$", "") + Else + sSheet = sAddress + End If + + ' Resolve sheet part: either a document named range, or the active sheet or a real sheet + Set oSheets = _Component.getSheets() + Set oNamedRanges = _Component.NamedRanges + If oSheets.hasByName(sSheet) Then + ElseIf sSheet = "~" And Len(sRange) > 0 Then + sSheet = _Component.CurrentController.ActiveSheet.Name + ElseIf oNamedRanges.hasByName(sSheet) Then + .XCellRange = oNamedRanges.getByName(sSheet).ReferredCells + sSheet = oSheets.getByIndex(oNamedRanges.getByName(sSheet).ReferencePosition.Sheet).Name + Else + sRange = sSheet + sSheet = _Component.CurrentController.ActiveSheet.Name + End If + .SheetName = sSheet + .XSpreadSheet = oSheets.getByName(sSheet) + .SheetIndex = .XSpreadSheet.RangeAddress.Sheet + + ' Resolve range part - either a sheet named range or the current selection or a real range or "" + If IsNull(.XCellRange) Then + Set oNamedRanges = .XSpreadSheet.NamedRanges + If sRange = "~" Then + Set oSelect = _Component.CurrentController.getSelection() + If oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections + Set .XCellRange = oSelect.getByIndex(0) + Else + Set .XCellRange = oSelect + End If + ElseIf sRange = "*" Or sRange = "" Then + vLastCell = _LastCell(.XSpreadSheet) + sRange = "A1:" & _GetColumnName(vLastCell(0)) & CStr(vLastCell(1)) + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + ElseIf oNamedRanges.hasByName(sRange) Then + .XCellRange = oNamedRanges.getByName(sRange).ReferredCells + Else + On Local Error GoTo CatchError + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + ' If range reaches the limits of the sheets, reduce it up to the used area + Set oRangeAddress = .XCellRange.RangeAddress + If oRangeAddress.StartColumn = 0 And oRangeAddress.EndColumn = MAXCOLS - 1 Then + vLastCell = _LastCell(.XSpreadSheet) + sRange = "A" & CStr(oRangeAddress.StartRow + 1) & ":" _ + & _GetColumnName(vLastCell(0)) & CStr(oRangeAddress.EndRow + 1) + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + ElseIf oRangeAddress.StartRow = 0 And oRangeAddress.EndRow = MAXROWS - 1 Then + vLastCell = _LastCell(.XSpreadSheet) + sRange = _GetColumnName(oRangeAddress.StartColumn + 1) & "1" & ":" _ + & _GetColumnName(oRangeAddress.EndColumn + 1) & CStr(_LastCell(.XSpreadSheet)(1)) + Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) + End If + End If + End If + If IsNull(.XCellRange) Then GoTo CatchAddress + + Set oRangeAddress = .XCellRange.RangeAddress + .RangeName = .XCellRange.AbsoluteName + .Height = oRangeAddress.EndRow - oRangeAddress.StartRow + 1 + .Width = oRangeAddress.EndColumn - oRangeAddress.StartColumn + 1 + + ' Remember the current component in case of use outside the current instance + Set .Component = _Component + + End With + + ' Store last parsed address for reuse + Set _LastParsedAddress = oAddress + +Finally: + Set _ParseAddress = oAddress + Exit Function +CatchError: + ScriptForge.SF_Exception.Clear() +CatchAddress: + ScriptForge.SF_Exception.RaiseFatal(CALCADDRESSERROR, "Range", psAddress _ + , "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc._ParseAddress + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvArg As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim oProperties As Object ' Document or Custom properties +Dim vLastCell As Variant ' Coordinates of last used cell in a sheet +Dim oSelect As Object ' Current selection +Dim vRanges As Variant ' List of selected ranges +Dim oAddress As Object ' _Address type for range description +Dim oCursor As Object ' com.sun.star.sheet.XSheetCellCursor +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + cstThisSub = "SFDocuments.Calc.get" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case UCase(psProperty) + Case UCase("CurrentSelection") + Set oSelect = _Component.CurrentController.getSelection() + If IsNull(oSelect) Then + _PropertyGet = Array() + ElseIf oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections + vRanges = Array() + For i = 0 To oSelect.Count - 1 + vRanges = ScriptForge.SF_Array.Append(vRanges, oSelect.getByIndex(i).AbsoluteName) + Next i + _PropertyGet = vRanges + Else + _PropertyGet = oSelect.AbsoluteName + End If + Case UCase("Height") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + _PropertyGet = 0 + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + _PropertyGet = _ParseAddress(pvArg).Height + End If + Case UCase("FirstCell"), UCase("FirstRow"), UCase("FirstColumn") _ + , UCase("LastCell"), UCase("LastColumn"), UCase("LastRow") _ + , UCase("SheetName") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then ' Avoid errors when instance is watched in Basic IDE + If InStr(UCase(psProperty), "CELL") > 0 Then _PropertyGet = "" Else _PropertyGet = -1 + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set oAddress = _ParseAddress(pvArg) + With oAddress.XCellRange + Select Case UCase(psProperty) + Case UCase("FirstCell") + _PropertyGet = A1Style(.RangeAddress.StartRow + 1, .RangeAddress.StartColumn + 1, , , oAddress.XSpreadsheet.Name) + Case UCase("FirstColumn") : _PropertyGet = CLng(.RangeAddress.StartColumn + 1) + Case UCase("FirstRow") : _PropertyGet = CLng(.RangeAddress.StartRow + 1) + Case UCase("LastCell") + _PropertyGet = A1Style(.RangeAddress.EndRow + 1, .RangeAddress.EndColumn + 1, , , oAddress.XSpreadsheet.Name) + Case UCase("LastColumn") : _PropertyGet = CLng(.RangeAddress.EndColumn + 1) + Case UCase("LastRow") : _PropertyGet = CLng(.RangeAddress.EndRow + 1) + Case UCase("SheetName") : _PropertyGet = oAddress.XSpreadsheet.Name + End Select + End With + End If + Case UCase("Range") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set _PropertyGet = _ParseAddress(pvArg) + End If + Case UCase("Region") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + _PropertyGet = "" + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set oAddress = _ParseAddress(pvArg) + With oAddress + Set oCursor = .XSpreadsheet.createCursorByRange(.XCellRange) + oCursor.collapseToCurrentRegion() + _PropertyGet = oCursor.AbsoluteName + End With + End If + Case UCase("Sheet") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally + Set _PropertyGet = _ParseAddress(pvArg) + End If + Case UCase("Sheets") + _PropertyGet = _Component.getSheets.getElementNames() + Case UCase("Width") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + _PropertyGet = 0 + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + _PropertyGet = _ParseAddress(pvArg).Width + End If + Case UCase("XCellRange") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set _PropertyGet = _ParseAddress(pvArg).XCellRange + End If + Case UCase("XSheetCellCursor") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally + Set oAddress = _ParseAddress(pvArg) + Set _PropertyGet = oAddress.XSpreadsheet.createCursorByRange(oAddress.XCellRange) + End If + Case UCase("XSpreadsheet") + If IsMissing(pvArg) Or IsEmpty(pvArg) Then + Set _PropertyGet = Nothing + Else + If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally + Set _PropertyGet = _Component.getSheets.getByName(pvArg) + End If + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Calc._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _QuoteSheetName(ByVal psSheetName As String) As String +''' Return the given sheet name surrounded with single quotes +''' when required to insert the sheet name into a Calc formula +''' Enclosed single quotes are doubled +''' Args: +''' psSheetName: the name to quote +''' Returns: +''' The quoted or unchanged sheet name + +Dim sSheetName As String ' Return value +Dim i As Long + +Try: + ' Surround the sheet name with single quotes when required by the presence of single quotes + If InStr(psSheetName, "'") > 0 Then + sSheetName = "'" & Replace(psSheetName, "'", "''") & "'" + Else + ' Surround the sheet name with single quotes when required by the presence of at least one of the special characters + sSheetName = psSheetName + For i = 1 To Len(cstSPECIALCHARS) + If InStr(sSheetName, Mid(cstSPECIALCHARS, i, 1)) > 0 Then + sSheetName = "'" & sSheetName & "'" + Exit For + End If + Next i + End If + +Finally: + _QuoteSheetName = sSheetName + Exit Function +End Function ' SFDocuments.SF_Calc._QuoteSheetName + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Calc instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DOCUMENT]: Type/File" + + _Repr = "[Calc]: " & [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Calc._Repr + +REM ----------------------------------------------------------------------------- +Private Sub _RestoreSelections(ByRef pvComponent As Variant _ + , ByRef pvSelection As Variant _ + ) +''' Set the selection to a single or a multiple range +''' Does not work well when multiple selections and macro terminating in Basic IDE +''' Called by the CopyToCell and CopyToRange methods +''' Args: +''' pvComponent: should work for foreign instances as well +''' pvSelection: the stored selection done previously by Component.CurrentController.getSelection() + +Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges +Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress +Dim i As Long + +Try: + If IsArray(pvSelection) Then + Set oCellRanges = pvComponent.createInstance("com.sun.star.sheet.SheetCellRanges") + vRangeAddresses = Array() + ReDim vRangeAddresses(0 To UBound(pvSelection)) + For i = 0 To UBound(pvSelection) + vRangeAddresses(i) = pvSelection.getByIndex(i).RangeAddress + Next i + oCellRanges.addRangeAddresses(vRangeAddresses, False) + pvComponent.CurrentController.select(oCellRanges) + Else + pvComponent.CurrentController.select(pvSelection) + End If + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_Calc._RestoreSelections + +REM ----------------------------------------------------------------------------- +Private Function _ValidateSheet(Optional ByRef pvSheetName As Variant _ + , Optional ByVal psArgName As String _ + , Optional ByVal pvNew As Variant _ + , Optional ByVal pvActive As Variant _ + , Optional ByVal pvOptional as Variant _ + , Optional ByVal pvNumeric As Variant _ + , Optional ByVal pvReference As Variant _ + , Optional ByVal pvResetSheet As Variant _ + ) As Boolean +''' Sheet designation validation function similar to the SF_Utils._ValidateXXX functions +''' Args: +''' pvSheetName: string or numeric position +''' pvArgName: the name of the variable to be used in the error message +''' pvNew: if True, sheet must not exist (default = False) +''' pvActive: if True, the shortcut "~" is accepted (default = False) +''' pvOptional: if True, a zero-length string is accepted (default = False) +''' pvNumeric: if True, the sheet position is accepted (default = False) +''' pvReference: if True, a sheet reference is acceptable (default = False) +''' pvNumeric and pvReference must not both be = True +''' pvResetSheet: if True, return in pvSheetName the correct (case-sensitive) sheet name (default = False) +''' Returns +''' True if valid. SheetName is reset to current value if = "~" +''' Exceptions +''' DUPLICATESHEETERROR A sheet with the given name exists already + +Dim vSheets As Variant ' List of sheets +Dim sSheet As String ' Sheet name without single quotes +Dim lSheet As Long ' Index in list of sheets +Dim vTypes As Variant ' Array of accepted variable types +Dim bValid As Boolean ' Return value + +Check: + If IsMissing(pvNew) Or IsEmpty(pvNew) Then pvNew = False + If IsMissing(pvActive) Or IsEmpty(pvActive) Then pvActive = False + If IsMissing(pvOptional) Or IsEmpty(pvOptional) Then pvOptional = False + If IsMissing(pvNumeric) Or IsEmpty(pvNumeric) Then pvNumeric = False + If IsMissing(pvReference) Or IsEmpty(pvReference) Then pvReference = False + If IsMissing(pvResetSheet) Or IsEmpty(pvResetSheet) Then pvResetSheet = False + + ' Define the acceptable variable types + If pvNumeric Then + vTypes = Array(V_STRING, V_NUMERIC) + ElseIf pvReference Then + vTypes = Array(V_STRING, ScriptForge.V_OBJECT) + Else + vTypes = V_STRING + End If + If Not ScriptForge.SF_Utils._Validate(pvSheetName, psArgName, vTypes, , , Iif(pvReference, CALCREFERENCE, "")) Then GoTo Finally + bValid = False + +Try: + If VarType(pvSheetName) = V_STRING Then + If pvOptional And Len(pvSheetName) = 0 Then + ElseIf pvActive And pvSheetName = "~" Then + pvSheetName = _Component.CurrentController.ActiveSheet.Name + Else + vSheets = _Component.getSheets.getElementNames() + sSheet = Replace(pvSheetName, "'", "") + If pvNew Then + If ScriptForge.SF_Array.Contains(vSheets, sSheet) Then GoTo CatchDuplicate + Else + If Not ScriptForge.SF_Utils._Validate(sSheet, psArgName, V_STRING, vSheets) Then GoTo Finally + If pvResetSheet Then + lSheet = ScriptForge.SF_Array.IndexOf(vSheets, sSheet, CaseSensitive := False) + pvSheetName = vSheets(lSheet) + End If + End If + End If + End If + bValid = True + +Finally: + _ValidateSheet = bValid + Exit Function +CatchDuplicate: + ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, psArgName, pvSheetName, "Document", [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Calc._ValidateSheet + +REM ============================================ END OF SFDOCUMENTS.SF_CALC + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Chart.xba b/wizards/source/sfdocuments/SF_Chart.xba new file mode 100644 index 000000000..0538fb8af --- /dev/null +++ b/wizards/source/sfdocuments/SF_Chart.xba @@ -0,0 +1,814 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Chart +''' ======== +''' +''' The SF_Chart module is focused on the description of chart documents +''' stored in Calc sheets. +''' With this service, many chart types and chart characteristics available +''' in the user interface can be read or modified. +''' +''' Definitions +''' Charts have 2 distinct names: +''' - an internal name, given by the LibreOffice application +''' - an optional user-defined name +''' In the scope of the ScriptForge libraries, the chart name is the name given by the user. +''' Only when there is no user name, the internal name may be used instead. +''' +''' Service invocation from the "Calc" service +''' Either make a new chart +''' calc.CreateChart(ChartName, SheetName, "SheetX.A1:C8") +''' or select an existing one +''' calc.Charts(SheetName, ChartName) +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_chart.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const CHARTEXPORTERROR = "CHARTEXPORTERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object ' Parent Calc document +Private ObjectType As String ' Must be CHART +Private ServiceName As String + +' Chart description +Private _SheetName As String ' Name of the Calc sheet containing the chart +Private _DrawIndex As Long ' Index of the chart in the sheet's draw page +Private _ChartName As String ' User name +Private _PersistentName As String ' Internal name +Private _Shape As Object ' com.sun.star.drawing.XShape +Private _Chart As Object ' com.sun.star.table.XTableChart +Private _ChartObject As Object ' com.sun.star.lang.XComponent - ScChartObj +Private _Diagram As Object ' com.sun.star.chart.XDiagram + +REM ============================================================ MODULE CONSTANTS + + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "CHART" + ServiceName = "SFDocuments.Chart" + _SheetName = "" + _DrawIndex = -1 + _ChartName = "" + _PersistentName = "" + Set _Shape = Nothing + Set _Chart = Nothing + Set _ChartObject = Nothing + Set _Diagram = Nothing +End Sub ' SFDocuments.SF_Chart Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Chart Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Chart Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ChartType() As Variant +''' The ChartType property specifies the type of chart as a string among next values: +''' Pie, Bar, Donut, Column, Area, Line, XY, Bubble, Net + ChartType = _PropertyGet("ChartType") +End Property ' SFDocuments.SF_Chart.ChartType (get) + +REM ----------------------------------------------------------------------------- +Property Let ChartType(Optional ByVal pvChartType As Variant) +''' Set the updatable property ChartType + _PropertySet("ChartType", pvChartType) +End Property ' SFDocuments.SF_Chart.ChartType (let) + +REM ----------------------------------------------------------------------------- +Property Get Deep() As Variant +''' If True, determines that in a three-dimensional bar chart the bars of each series are arranged behind each other in the z-direction. +''' If False the arrangement of bars is like in two-dimensional bar charts. +''' Bar and Column chart types only + Deep = _PropertyGet("Deep") +End Property ' SFDocuments.SF_Chart.Deep (get) + +REM ----------------------------------------------------------------------------- +Property Let Deep(Optional ByVal pvDeep As Variant) +''' Set the updatable property Deep + _PropertySet("Deep", pvDeep) +End Property ' SFDocuments.SF_Chart.Deep (let) + +REM ----------------------------------------------------------------------------- +Property Get Dim3D() As Variant +''' The Dim3D property specifies if the chart is displayed with 3D elements +''' String or Boolean +''' When String, must be 1 of next values: Bar, Cylinder, Cone or Pyramid +''' When Boolean True, Bar is assumed; when False, no 3D to be applied + Dim3D = _PropertyGet("Dim3D") +End Property ' SFDocuments.SF_Chart.Dim3D (get) + +REM ----------------------------------------------------------------------------- +Property Let Dim3D(Optional ByVal pvDim3D As Variant) +''' Set the updatable property Dim3D + _PropertySet("Dim3D", pvDim3D) +End Property ' SFDocuments.SF_Chart.Dim3D (let) + +REM ----------------------------------------------------------------------------- +Property Get Exploded() As Variant +''' the offset by which pie segments in a PieDiagram (pie or donut) are dragged outside from the center. +''' This value is given in percent of the radius. + Exploded = _PropertyGet("Exploded") +End Property ' SFDocuments.SF_Chart.Exploded (get)_ChartObject + +REM ----------------------------------------------------------------------------- +Property Let Exploded(Optional ByVal pvExploded As Variant) +''' Set the updatable property Exploded + _PropertySet("Exploded", pvExploded) +End Property ' SFDocuments.SF_Chart.Exploded (let) + +REM ----------------------------------------------------------------------------- +Property Get Filled() As Variant +''' When True, the Net diagram is said of FilledNet type +''' Net chart type only + Filled = _PropertyGet("Filled") +End Property ' SFDocuments.SF_Chart.Filled (get) + +REM ----------------------------------------------------------------------------- +Property Let Filled(Optional ByVal pvFilled As Variant) +''' Set the updatable property Filled + _PropertySet("Filled", pvFilled) +End Property ' SFDocuments.SF_Chart.Filled (let) + +REM ----------------------------------------------------------------------------- +Property Get Legend() As Variant +''' Specifies if the chart has a legend + Legend = _PropertyGet("Legend") +End Property ' SFDocuments.SF_Chart.Legend (get) + +REM ----------------------------------------------------------------------------- +Property Let Legend(Optional ByVal pvLegend As Variant) +''' Set the updatable property Legend + _PropertySet("Legend", pvLegend) +End Property ' SFDocuments.SF_Chart.Legend (let) + +REM ----------------------------------------------------------------------------- +Property Get Percent() As Variant +''' When True, the series of the diagram are stacked and each category sums up to 100%. +''' Area, Bar, Bubble, Column and Net chart types only_ChartObject + Percent = _PropertyGet("Percent") +End Property ' SFDocuments.SF_Chart.Percent (get) + +REM ----------------------------------------------------------------------------- +Property Let Percent(Optional ByVal pvPercent As Variant) +''' Set the updatable property Percent + _PropertySet("Percent", pvPercent) +End Property ' SFDocuments.SF_Chart.Percent (let) + +REM ----------------------------------------------------------------------------- +Property Get Stacked() As Variant +''' When True, the series of the diagram are stacked. +''' Area, Bar, Bubble, Column and Net chart types only + Stacked = _PropertyGet("Stacked") +End Property ' SFDocuments.SF_Chart.Stacked (get) + +REM ----------------------------------------------------------------------------- +Property Let Stacked(Optional ByVal pvStacked As Variant) +''' Set the updatable property Stacked + _PropertySet("Stacked", pvStacked) +End Property ' SFDocuments.SF_Chart.Stacked (let) + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant +''' Specifies the main title of the chart + Title = _PropertyGet("Title") +End Property ' SFDocuments.SF_Chart.Title (get) + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) +''' Set the updatable property Title + _PropertySet("Title", pvTitle) +End Property ' SFDocuments.SF_Chart.Title (let) + +REM ----------------------------------------------------------------------------- +Property Get XTitle() As Variant +''' Specifies the main XTitle of the chart + XTitle = _PropertyGet("XTitle") +End Property ' SFDocuments.SF_Chart.XTitle (get) + +REM ----------------------------------------------------------------------------- +Property Let XTitle(Optional ByVal pvXTitle As Variant) +''' Set the updatable property XTitle + _PropertySet("XTitle", pvXTitle) +End Property ' SFDocuments.SF_Chart.XTitle (let) + +REM ----------------------------------------------------------------------------- +Property Get YTitle() As Variant +''' Specifies the main YTitle of the chart + YTitle = _PropertyGet("YTitle") +End Property ' SFDocuments.SF_Chart.YTitle (get) + +REM ----------------------------------------------------------------------------- +Property Let YTitle(Optional ByVal pvYTitle As Variant) +''' Set the updatable property YTitle + _PropertySet("YTitle", pvYTitle) +End Property ' SFDocuments.SF_Chart.YTitle (let) + +REM ----------------------------------------------------------------------------- +Property Get XChartObj() As Variant +''' com.sun.star.lang.XComponent - ScChartObj + ChartType = _PropertyGet("XChartObj") +End Property ' SFDocuments.SF_Chart.XChartObj (get) + +REM ----------------------------------------------------------------------------- +Property Get XDiagram() As Variant +''' com.sun.star.chart.XDiagram + ChartType = _PropertyGet("XDiagram") +End Property ' SFDocuments.SF_Chart.XDiagram (get) + +REM ----------------------------------------------------------------------------- +Property Get XShape() As Variant +''' com.sun.star.drawing.XShape + ChartType = _PropertyGet("XShape") +End Property ' SFDocuments.SF_Chart.XShape (get) + +REM ----------------------------------------------------------------------------- +Property Get XTableChart() As Variant +''' com.sun.star.table.XTableChart + ChartType = _PropertyGet("XTableChart") +End Property ' SFDocuments.SF_Chart.XTableChart (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function ExportToFile(Optional ByVal FileName As Variant _ + , Optional ByVal ImageType As Variant _ + , Optional ByVal Overwrite As Variant _ + ) As Boolean +''' Store the chart as an image to the given file location +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' ImageType: the name of the targeted image type +''' Allowed values: gif, jpeg, png (default), svg and tiff +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' CHARTEXPORTERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oChart.ExportToFile("C:\Me\Chart2.gif", ImageType := "gif", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vStoreArguments As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Dim oExport As Object ' com.sun.star.drawing.GraphicExportFilter +Dim vImageTypes As Variant ' Array of permitted image types +Dim vMimeTypes As Variant ' Array of corresponding mime types in the same order as vImageTypes + +Const cstImageTypes = "gif,jpeg,png,svg,tiff" +Const cstMimeTypes = "image/gif,image/jpeg,image/png,image/svg+xml,image/tiff" + +Const cstThisSub = "SFDocuments.Chart.ExportToFile" +Const cstSubArgs = "FileName, [ImageType=""png""|""gif""|""jpeg""|""svg""|""tiff""], [Overwrite=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(ImageType) Or IsEmpty(ImageType) Then ImageType = "png" + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + + vImageTypes = Split(cstImageTypes, ",") + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ImageType, "ImageType", V_STRING, vImageTypes) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + vMimeTypes = Split(cstMimeTypes, ",") + vStoreArguments = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("URL", sFile) _ + , ScriptForge.SF_Utils._MakePropertyValue("MediaType" _ + , vMimeTypes(ScriptForge.SF_Array.IndexOf(vImageTypes, ImageType, CaseSensitive := False))) _ + ) + ' Export with the com.sun.star.drawing.GraphicExportFilter UNO service + Set oExport = ScriptForge.SF_Utils._GetUNOService("GraphicExportFilter") + With oExport + .setSourceDocument(_Shape) + .filter(vStoreArguments) + End With + bSaved = True + +Finally: + ExportToFile = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(CHARTEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite) + GoTo Finally +End Function ' SFDocuments.SF_Chart.ExportToFile + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Chart.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Chart.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Chart service as an array + + Methods = Array( _ + "ExportToFile" _ + , "Resize" _ + ) + +End Function ' SFDocuments.SF_Chart.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Chart class as an array + + Properties = Array( _ + "ChartType" _ + , "Deep" _ + , "Dim3D" _ + , "Exploded" _ + , "Filled" _ + , "Legend" _ + , "Percent" _ + , "Stacked" _ + , "Title" _ + , "XChartObj" _ + , "XDiagram" _ + , "XShape" _ + , "XTableChart" _ + , "XTitle" _ + , "YTitle" _ + ) + +End Function ' SFDocuments.SF_Chart.Properties + +REM ----------------------------------------------------------------------------- +Public Function Resize(Optional ByVal XPos As Variant _ + , Optional ByVal YPos As Variant _ + , Optional ByVal Width As Variant _ + , Optional ByVal Height As Variant _ + ) As Boolean +''' Move the topleft corner of a chart to new coordinates and/or modify its dimensions +''' All distances are expressed in 1/100th mm +''' Args: +''' XPos : the vertical distance from the topleft corner +''' YPos : the horizontal distance from the topleft corner +''' Width : the horizontal width of the shape containing the chart +''' Height : the vertical height of the shape containing the chart +''' Negative or missing arguments are left unchanged +''' Returns: +''' True when successful +''' Examples: +''' oChart.Resize(1000, 2000, Height := 6000) ' Width is not changed + +Dim bResize As Boolean ' Return value +Dim oPosition As Object ' com.sun.star.awt.Point +Dim oSize As Object ' com.sun.star.awt.Size +Const cstThisSub = "SFDocuments.Chart.Resize" +Const cstSubArgs = "[XPos], [YPos], [Width], [Height]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bResize = False + +Check: + If IsMissing(XPos) Or IsEmpty(XPos) Then XPos = -1 + If IsMissing(YPos) Or IsEmpty(YPos) Then YPos = -1 + If IsMissing(Height) Or IsEmpty(Height) Then Height = -1 + If IsMissing(Width) Or IsEmpty(Width) Then Width = -1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(XPos, "XPos", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(YPos, "YPos", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + With _Shape + ' Get the current values + Set oPosition = .Position + Set oSize = .Size + ' Modify relevant elements + If XPos >= 0 Then oPosition.X = CLng(XPos) + If YPos >= 0 Then oPosition.Y = CLng(YPos) + If Width > 0 Then oSize.Width = CLng(Width) + If Height > 0 Then oSize.Height = CLng(Height) + ' Rewrite + .setPosition(oPosition) + .setSize(oSize) + End With + bResize = True + +Finally: + Resize = bResize + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SF_Documents.SF_Chart.Resize + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Chart.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Chart.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Static oSession As Object ' Alias of SF_Session +Dim vData As Variant ' Data points array of values + +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDocuments.Chart.get" & psProperty + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("ChartType") + With _Diagram + Select Case .DiagramType + Case "com.sun.star.chart.BarDiagram" + If .Vertical Then _PropertyGet = "Bar" Else _PropertyGet = "Column" + Case "com.sun.star.chart.PieDiagram" + _PropertyGet = "Pie" + Case "com.sun.star.chart.DonutDiagram" + _PropertyGet = "Donut" + Case "com.sun.star.chart.AreaDiagram" + _PropertyGet = "Area" + Case "com.sun.star.chart.LineDiagram" + _PropertyGet = "Line" + Case "com.sun.star.chart.XYDiagram" + _PropertyGet = "XY" + Case "com.sun.star.chart.BubbleDiagram" + _PropertyGet = "Bubble" + Case "com.sun.star.chart.NetDiagram", "com.sun.star.chart.FilledNetDiagram" + _PropertyGet = "Net" + Case Else + _PropertyGet = "" + End Select + End With + Case UCase("Deep") + If oSession.HasUnoProperty(_Diagram, "Deep") Then _PropertyGet = _Diagram.Deep Else _PropertyGet = False + Case UCase("Dim3D") + If oSession.HasUnoProperty(_Diagram, "Dim3D") Then + If _Diagram.Dim3D Then + If oSession.HasUnoProperty(_Diagram, "SolidType") Then + Select Case _Diagram.SolidType + Case com.sun.star.chart.ChartSolidType.RECTANGULAR_SOLID : _PropertyGet = "Bar" + Case com.sun.star.chart.ChartSolidType.CYLINDER : _PropertyGet = "Cylinder" + Case com.sun.star.chart.ChartSolidType.CONE : _PropertyGet = "Cone" + Case com.sun.star.chart.ChartSolidType.PYRAMID : _PropertyGet = "Pyramid" + End Select + Else + _PropertyGet = _Diagram.Dim3D + End If + Else + _PropertyGet = False + End If + Else + _PropertyGet = False + End If + Case UCase("Exploded") + If oSession.HasUnoProperty(_ChartObject, "Data") Then + ' All data points are presumed exploded with the same coefficient. Determine the (0, 0)th + With _ChartObject + vData = .Data.Data + _PropertyGet = 0 + If IsArray(vData) Then + If UBound(vData) >= 0 Then + If IsArray(vData(0)) Then + If UBound(vData(0)) >= 0 Then _PropertyGet = _Diagram.getDataPointProperties(0, 0).SegmentOffset + End If + End If + End If + End With + End If + Case UCase("Filled") + _PropertyGet = ( _Diagram.DiagramType = "com.sun.star.chart.FilledNetDiagram" ) + Case UCase("Legend") + If oSession.HasUnoProperty(_ChartObject, "HasLegend") Then _PropertyGet = _ChartObject.HasLegend Else _PropertyGet = False + Case UCase("Percent") + If oSession.HasUnoProperty(_Diagram, "Percent") Then _PropertyGet = _Diagram.Percent Else _PropertyGet = False + Case UCase("Stacked") + If oSession.HasUnoProperty(_Diagram, "Stacked") Then _PropertyGet = _Diagram.Stacked Else _PropertyGet = False + Case UCase("Title") + If oSession.HasUnoProperty(_ChartObject, "HasMainTitle") Then + If _ChartObject.HasMainTitle Then _PropertyGet = _ChartObject.Title.String Else _PropertyGet = "" + End If + Case UCase("XTitle") + If oSession.HasUnoProperty(_Diagram, "HasXAxisTitle") Then + If _Diagram.HasXAxisTitle Then _PropertyGet = _Diagram.XAxisTitle.String Else _PropertyGet = "" + End If + Case UCase("YTitle") + If oSession.HasUnoProperty(_Diagram, "HasYAxisTitle") Then + If _Diagram.HasYAxisTitle Then _PropertyGet = _Diagram.YAxisTitle.String Else _PropertyGet = "" + End If + Case UCase("XChartObj") + Set _PropertyGet = _ChartObject + Case UCase("XDiagram") + Set _PropertyGet = _Diagram + Case UCase("XShape") + Set _PropertyGet = _Shape + Case UCase("XTableChart") + Set _PropertyGet = _Chart + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Chart._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim sChartType As String ' Diagram type +Dim bDim3D As Boolean ' Alias of Dim3D property of diagram +Dim bVertical As Boolean ' When True, chart type is a bar, not a column +Dim vData As Variant ' Data points array of values +Dim i As Long, j As Long +Const cstChart = "com.sun.star.chart." + +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Chart.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Catch + + bSet = True + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("ChartType") + If Not ScriptForge.SF_Utils._Validate(pvValue, "ChartType", V_STRING _ + , Array("Bar", "Column", "Pie", "Donut", "Area", "Line", "XY", "Bubble", "Net") _ + ) Then GoTo Finally + With _Diagram + ' Specify the targeted chart type + Select Case UCase(pvValue) + Case "BAR", "COLUMN" : sChartType = cstChart & "BarDiagram" + Case "PIE" : sChartType = cstChart & "PieDiagram" + Case "DONUT" : sChartType = cstChart & "DonutDiagram" + Case "AREA" : sChartType = cstChart & "AreaDiagram" + Case "LINE" : sChartType = cstChart & "LineDiagram" + Case "XY" : sChartType = cstChart & "XYDiagram" + Case "BUBBLE" : sChartType = cstChart & "BubbleDiagram" + Case "NET" : sChartType = cstChart & "NetDiagram" + End Select + ' If there is no change, do nothing + If sChartType <> .DiagramType Then + ' Some combinations old type => new type require the cancellation of 3D graphs + bDim3D = .Dim3D + .Dim3D = False + _ChartObject.createInstance(sChartType) + Set _Diagram = _ChartObject.Diagram + .Dim3D = bDim3D + End If + If UCase(pvValue) = "BAR" Or UCase(pvValue) = "COLUMN" Then .Vertical = ( UCase(pvValue) = "BAR" ) + End With + Case UCase("Deep") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Deep", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "Deep") Then _Diagram.Deep = pvValue + Case UCase("Dim3D") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Dim3D", Array(ScriptForge.V_Boolean, V_STRING) _ + , Array(False, True, "Bar", "Cylinder", "Cone", "Pyramid") _ + ) Then GoTo Finally + With _Diagram + If oSession.HasUnoProperty(_Diagram, "Dim3D") Then + If _Diagram.DiagramType = "com.sun.star.chart.BubbleDiagram" Then + .Dim3D = False ' Force False value to avoid empty graph + ElseIf VarType(pvValue) = V_STRING Then + bVertical = .Vertical + .Dim3D = True + .Vertical = bVertical + If oSession.HasUnoProperty(_Diagram, "SolidType") Then + If .DiagramType = cstChart & "BarDiagram" Then + Select Case UCase(pvValue) + Case "BAR" : .SolidType = com.sun.star.chart.ChartSolidType.RECTANGULAR_SOLID + Case "CYLINDER" : .SolidType = com.sun.star.chart.ChartSolidType.CYLINDER + Case "CONE" : .SolidType = com.sun.star.chart.ChartSolidType.CONE + Case "PYRAMID" : .SolidType = com.sun.star.chart.ChartSolidType.PYRAMID + End Select + Else + .SolidType = 0 + End If + End If + Else ' Boolean + If oSession.HasUnoProperty(_Diagram, "SolidType") Then .SolidType = 0 + .Dim3D = pvValue + End If + End If + End With + Case UCase("Exploded") + If oSession.HasUnoProperty(_ChartObject, "Data") And _Diagram.DiagramType <> "com.sun.star.chart.BubbleDiagram" Then + ' All data points are presumed exploded with the same coefficient + If Not ScriptForge.SF_Utils._Validate(pvValue, "Exploded", ScriptForge.V_NUMERIC) Then GoTo Finally + With _ChartObject + vData = .Data.Data + If IsArray(vData) Then + For i = 0 To UBound(vData) + If IsArray(vData(i)) Then + For j = 0 To UBound(vData(i)) + _Diagram.getDataPointProperties(i, j).SegmentOffset = CLng(pvValue) + Next j + End If + Next i + End If + End With + End If + Case UCase("Filled") + ' Flipflop between NetDiagram and FilledNetDiagram + If Not ScriptForge.SF_Utils._Validate(pvValue, "Filled", ScriptForge.V_BOOLEAN) Then GoTo Finally + With _Diagram + ' Specify the targeted chart type + sChartType = cstChart & Iif(pvValue, "Filled", "") & "NetDiagram" + ' If there is no change, do nothing + If sChartType <> .DiagramType then + ' Do not apply if the chart type not = "Net" + If (pvValue And .DiagramType = cstChart & "NetDiagram") _ + Or (Not pvValue And .DiagramType = cstChart & "FilledNetDiagram") Then + ' Some combinations old type => new type require the cancellation of 3D graphs + bDim3D = .Dim3D + .Dim3D = False + _ChartObject.createInstance(sChartType) + Set _Diagram = _ChartObject.Diagram + .Dim3D = bDim3D + End If + End If + End With + Case UCase("Legend") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Legend", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ChartObject, "HasLegend") Then _ChartObject.HasLegend = pvValue + Case UCase("Percent") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Percent", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "Percent") Then + _Diagram.Stacked = pvValue + _Diagram.Percent = pvValue + End If + Case UCase("Stacked") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Stacked", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "Stacked") Then + _Diagram.Stacked = pvValue + If Not pvValue Then _Diagram.Percent = False + End If + Case UCase("Title") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Title", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ChartObject, "HasMainTitle") Then + _ChartObject.HasMainTitle = ( Len(pvValue) > 0 ) + If Len(pvValue) > 0 Then _ChartObject.Title.String = pvValue + End If + Case UCase("XTitle") + If Not ScriptForge.SF_Utils._Validate(pvValue, "XTitle", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "HasXAxisTitle") Then + _Diagram.HasXAxisTitle = ( Len(pvValue) > 0 ) + If Len(pvValue) > 0 Then _Diagram.XAxisTitle.String = pvValue + End If + Case UCase("YTitle") + If Not ScriptForge.SF_Utils._Validate(pvValue, "YTitle", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_Diagram, "HasYAxisTitle") Then + _Diagram.HasYAxisTitle = ( Len(pvValue) > 0 ) + If Len(pvValue) > 0 Then _Diagram.YAxisTitle.String = pvValue + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bSet = False + GoTo Finally +End Function ' SFDocuments.SF_FormControl._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Chart instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Chart]: Name - Type + + _Repr = "[Chart]: " & ChartName & " - " & ChartType + +End Function ' SFDocuments.SF_Chart._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_CHART + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Document.xba b/wizards/source/sfdocuments/SF_Document.xba new file mode 100644 index 000000000..c54409445 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Document.xba @@ -0,0 +1,1504 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Document +''' =========== +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' managing and manipulating LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the +''' current SF_Document module +''' - saving, closing documents +''' - accessing their standard or custom properties +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ... +''' +''' Documents might contain forms. The current service gives access to the "SFDocuments.Form" service +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties implemented below +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The current module is closely related to the "UI" and "FileSystem" services +''' of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.GetDocument("Untitled 1") +''' ' or Set oDoc = ui.CreateDocument("Calc", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.odt") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", "Untitled 1") ' Default = ActiveWindow +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_document.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const DOCUMENTDEADERROR = "DOCUMENTDEADERROR" +Private Const DOCUMENTSAVEERROR = "DOCUMENTSAVEERROR" +Private Const DOCUMENTSAVEASERROR = "DOCUMENTSAVEASERROR" +Private Const DOCUMENTREADONLYERROR = "DOCUMENTREADONLYERROR" + +Private Const FORMDEADERROR = "FORMDEADERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private [_SubClass] As Object ' Subclass instance +Private ObjectType As String ' Must be DOCUMENT +Private ServiceName As String + +' Window description +Private _Component As Object ' com.sun.star.lang.XComponent +Private _Frame As Object ' com.sun.star.comp.framework.Frame +Private _WindowName As String ' Object Name +Private _WindowTitle As String ' Only mean to identify new documents +Private _WindowFileName As String ' URL of file name +Private _DocumentType As String ' Writer, Calc, ... + +' Properties (work variables - real properties could have been set manually by user) +Private _DocumentProperties As Object ' Dictionary of document properties +Private _CustomProperties As Object ' Dictionary of custom properties + +REM ============================================================ MODULE CONSTANTS + +Const ISDOCFORM = 1 ' Form is stored in a Writer document + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + Set [_SubClass] = Nothing + ObjectType = "DOCUMENT" + ServiceName = "SFDocuments.Document" + Set _Component = Nothing + Set _Frame = Nothing + _WindowName = "" + _WindowTitle = "" + _WindowFileName = "" + _DocumentType = "" + Set _DocumentProperties = Nothing + Set _CustomProperties = Nothing +End Sub ' SFDocuments.SF_Document Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Document Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Document Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CustomProperties() As Variant +''' Returns a dictionary of all custom properties of the document + CustomProperties = _PropertyGet("CustomProperties") +End Property ' SFDocuments.SF_Document.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) +''' Sets the updatable custom properties +''' The argument is a dictionary + +Dim vPropertyValues As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vCustomProperties As Variant ' Alias of argument +Dim oUserdefinedProperties As Object ' Custom properties object +Dim vOldPropertyValues As Variant ' Array of (to remove) existing user defined properties +Dim oProperty As Object ' Single com.sun.star.beans.PropertyValues +Dim sProperty As String ' Property name +Dim vKeys As Variant ' Array of dictionary keys +Dim vItems As Variant ' Array of dictionary items +Dim vValue As Variant ' Value to store in property +Dim iAttribute As Integer ' com.sun.star.beans.PropertyAttribute.REMOVEABLE +Dim i As Long +Const cstThisSub = "SFDocuments.Document.setCustomProperties" +Const cstSubArgs = "CustomProperties" + + On Local Error GoTo Catch + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvCustomProperties, "CustomProperties", ScriptForge.V_OBJECT, , , "DICTIONARY") Then GoTo Finally + End If + +Try: + Set oUserDefinedProperties = _Component.getDocumentProperties().UserDefinedProperties + + Set vCustomProperties = pvCustomProperties ' To avoid "Object variable not set" error + With vCustomProperties + + ' All existing custom properties must first be removed to avoid type conflicts + vOldPropertyValues = oUserDefinedProperties.getPropertyValues + For Each oProperty In vOldPropertyValues + sProperty = oProperty.Name + oUserDefinedProperties.removeProperty(sProperty) + Next oProperty + + ' Insert new properties one by one after type adjustment (dates, arrays, numbers) + vKeys = .Keys + vItems = .Items + iAttribute = com.sun.star.beans.PropertyAttribute.REMOVEABLE + For i = 0 To UBound(vKeys) + If VarType(vItems(i)) = V_DATE Then + vValue = ScriptForge.SF_Utils._CDateToUnoDate(vItems(i)) + ElseIf IsArray(vItems(i)) Then + vValue = Null + ElseIf ScriptForge.SF_Utils._VarTypeExt(vItems(i)) = ScriptForge.V_NUMERIC Then + vValue = CreateUnoValue("double", vItems(i)) + Else + vValue = vItems(i) + End If + oUserDefinedProperties.addProperty(vKeys(i), iAttribute, vValue) + Next i + + ' Declare the document as changed + _Component.setModified(True) + End With + + ' Reload custom properties in current object instance + _PropertyGet("CustomProperties") + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +Catch: + GoTo Finally +End Property ' SFDocuments.SF_Document.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant +''' Returns the updatable document property Description + Description = _PropertyGet("Description") +End Property ' SFDocuments.SF_Document.Description + +REM ----------------------------------------------------------------------------- +Property Let Description(Optional ByVal pvDescription As Variant) +''' Sets the updatable document property Description +''' If multilined, separate lines by "\n" escape sequence or by hard breaks + +Dim sDescription As String ' Alias of pvDescription +Const cstThisSub = "SFDocuments.Document.setDescription" +Const cstSubArgs = "Description" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvDescription, "Description", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + sDescription = Replace(pvDescription, "\n", ScriptForge.SF_String.sfNEWLINE) + _Component.DocumentProperties.Description = sDescription + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Description", sdescription) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Description + +REM ----------------------------------------------------------------------------- +Property Get DocumentProperties() As Variant +''' Returns a dictionary of all standard document properties, custom properties are excluded + DocumentProperties = _PropertyGet("DocumentProperties") +End Property ' SFDocuments.SF_Document.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String +''' Returns "Base", "Calc", "Draw", ... or "Writer" + DocumentType = _PropertyGet("DocumentType") +End Property ' SFDocuments.SF_Document.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get ExportFilters() As Variant +''' Returns the list of the export filter names applicable to the current document +''' as a zero-based array of strings +''' Import/Export filters are included + ExportFilters = _PropertyGet("ExportFilters") +End Property ' SFDocuments.SF_Document.ExportFilters + +REM ----------------------------------------------------------------------------- +Property Get ImportFilters() As Variant +''' Returns the list of the import filter names applicable to the current document +''' as a zero-based array of strings +''' Import/Export filters are included + ImportFilters = _PropertyGet("ImportFilters") +End Property ' SFDocuments.SF_Document.ImportFilters + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = _PropertyGet("IsBase") +End Property ' SFDocuments.SF_Document.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = _PropertyGet("IsCalc") +End Property ' SFDocuments.SF_Document.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = _PropertyGet("IsDraw") +End Property ' SFDocuments.SF_Document.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = _PropertyGet("IsImpress") +End Property ' SFDocuments.SF_Document.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = _PropertyGet("IsMath") +End Property ' SFDocuments.SF_Document.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = _PropertyGet("IsWriter") +End Property ' SFDocuments.SF_Document.IsWriter + +REM ----------------------------------------------------------------------------- +Property Get Keywords() As Variant +''' Returns the updatable document property Keywords + Keywords = _PropertyGet("Keywords") +End Property ' SFDocuments.SF_Document.Keywords + +REM ----------------------------------------------------------------------------- +Property Let Keywords(Optional ByVal pvKeywords As Variant) +''' Sets the updatable document property Keywords + +Dim vKeywords As Variant ' Alias of pvKeywords +Const cstThisSub = "SFDocuments.Document.setKeywords" +Const cstSubArgs = "Keywords" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvKeywords, "Keywords", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + vKeywords = ScriptForge.SF_Array.TrimArray(Split(pvKeywords, ",")) + _Component.DocumentProperties.Keywords = vKeywords + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Keywords", Join(vKeywords, ", ")) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Keywords + +REM ----------------------------------------------------------------------------- +Property Get Readonly() As Boolean +''' Returns True if the document must not be modified + Readonly = _PropertyGet("Readonly") +End Property ' SFDocuments.SF_Document.Readonly + +REM ----------------------------------------------------------------------------- +Property Get Subject() As Variant +''' Returns the updatable document property Subject + Subject = _PropertyGet("Subject") +End Property ' SFDocuments.SF_Document.Subject + +REM ----------------------------------------------------------------------------- +Property Let Subject(Optional ByVal pvSubject As Variant) +''' Sets the updatable document property Subject + +Const cstThisSub = "SFDocuments.Document.setSubject" +Const cstSubArgs = "Subject" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvSubject, "Subject", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + _Component.DocumentProperties.Subject = pvSubject + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Subject", pvSubject) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Subject + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant +''' Returns the updatable document property Title + Title = _PropertyGet("Title") +End Property ' SFDocuments.SF_Document.Title + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) +''' Sets the updatable document property Title + +Const cstThisSub = "SFDocuments.Document.setTitle" +Const cstSubArgs = "Title" + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(pvTitle, "Title", V_STRING) Then GoTo Finally + End If + +Try: + ' Update in UNO component object and in current instance + _Component.DocumentProperties.Title = pvTitle + If Not IsNull(_DocumentProperties) Then _DocumentProperties.ReplaceItem("Title", pvTitle) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Property +End Property ' SFDocuments.SF_Document.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant +''' Returns the com.sun.star.lang.XComponent UNO object representing the document + XComponent = _PropertyGet("XComponent") +End Property ' SFDocuments.SF_Document.XComponent + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean +''' Make the current document active +''' Args: +''' Returns: +''' True if the document could be activated +''' Otherwise, there is no change in the actual user interface +''' Examples: +''' oDoc.Activate() + +Dim bActivate As Boolean ' Return value +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDocuments.Document.Activate" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActivate = False + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + +Try: + Set oContainer = _Frame.ContainerWindow + With oContainer + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .toFront() ' Force window change in Linux + Wait 1 ' Bypass desynchro issue in Linux + End With + bActivate = True + +Finally: + Activate = bActivate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean +''' Close the document. Does nothing if the document is already closed +''' regardless of how the document was closed, manually or by program +''' Args: +''' SaveAsk: If True (default), the user is invited to confirm or not the writing of the changes on disk +''' No effect if the document was not modified +''' Returns: +''' False if the user declined to close +''' Examples: +''' If oDoc.CloseDocument() Then +''' ' ... + +Dim bClosed As Boolean ' return value +Dim oDispatch ' com.sun.star.frame.DispatchHelper +Const cstThisSub = "SFDocuments.Document.CloseDocument" +Const cstSubArgs = "[SaveAsk=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClosed = False + +Check: + If IsMissing(SaveAsk) Or IsEmpty(SaveAsk) Then SaveAsk = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SaveAsk, "SaveAsk", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + If SaveAsk And _Component.IsModified Then ' Execute closure with the File/Close menu command + Activate() + RunCommand("CloseDoc") + bClosed = _IsStillAlive(, False) ' Do not raise error + Else + _Frame.close(True) + _Frame.dispose() + bClosed = True + End If + +Finally: + If bClosed Then Dispose() + CloseDocument = bClosed + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + , Optional ByRef _Document As Variant _ + ) As Object +''' Create a new menu entry in the document's menubar +''' The menu is not intended to be saved neither in the LibreOffice global environment, nor in the document +''' The method returns a SFWidgets.Menu instance. Its methods let define the menu further. +''' Args: +''' MenuHeader: the name/header of the menu +''' Before: the place where to put the new menu on the menubar (string or number >= 1) +''' When not found => last position +''' SubmenuChar: the delimiter used in menu trees. Default = ">" +''' _Document: undocumented argument to designate the document where the menu will be located +''' Returns: +''' A SFWidgets.Menu instance or Nothing +''' Examples: +''' Dim oMenu As Object +''' Set oMenu = oDoc.CreateMenu("My menu", Before := "Styles") +''' With oMenu +''' .AddItem("Item 1", Command := "About") +''' '... +''' .Dispose() ' When definition is complete, the menu instance may be disposed +''' End With +''' ' ... + +Dim oMenu As Object ' return value +Const cstThisSub = "SFDocuments.Document.CreateMenu" +Const cstSubArgs = "MenuHeader, [Before=""""], [SubmenuChar="">""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oMenu = Nothing + +Check: + If IsMissing(Before) Or IsEmpty(Before) Then Before = "" + If IsMissing(SubmenuChar) Or IsEmpty(SubmenuChar) Then SubmenuChar = "" + If IsMissing(_Document) Or IsEmpty(_Document) Or IsNull(_Document) Then Set _Document = _Component + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MenuHeader, "MenuHeader", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Before, "Before", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SubmenuChar, "SubmenuChar", V_STRING) Then GoTo Finally + End If + +Try: + Set oMenu = ScriptForge.SF_Services.CreateScriptService("SFWidgets.Menu", _Document, MenuHeader, Before, SubmenuChar) + +Finally: + Set CreateMenu = oMenu + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function ExportAsPDF(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal Watermark As Variant _ + ) As Boolean +''' Store the document to the given file location in PDF format +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Password: password to open the document +''' Watermark: the text for a watermark to be drawn on every page of the exported PDF file +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEASERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.ExportAsPDF("C:\Me\myDoc.pdf", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim sFilter As String ' One of the pdf filter names +Dim vFilterData As Variant ' Array of com.sun.star.beans.PropertyValue +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Document.ExportAsPDF" +Const cstSubArgs = "FileName, [Overwrite=False], [Pages=""""], [Password=""""], [Watermark=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(Watermark) Or IsEmpty(Watermark) Then Watermark = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(Watermark, "Watermark", V_STRING) Then GoTo Finally + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + sFilter = LCase(_DocumentType) & "_pdf_Export" + ' FilterData parameters are added only if they are meaningful + vFilterData = Array() + If Len(Pages) > 0 Then + vFilterData = ScriptForge.SF_Array.Append(vFilterData _ + , ScriptForge.SF_Utils._MakePropertyValue("PageRange", Pages)) + End If + If Len(Password) > 0 Then + vFilterData = ScriptForge.SF_Array.Append(vFilterData _ + , ScriptForge.SF_Utils._MakePropertyValue("EncryptFile", True) _ + , ScriptForge.SF_Utils._MakePropertyValue("DocumentOpenPassword", Password)) + End If + If Len(Watermark) > 0 Then + vFilterData = ScriptForge.SF_Array.Append(vFilterData _ + , ScriptForge.SF_Utils._MakePropertyValue("Watermark", Watermark)) + End If + + ' Finalize properties and export + vProperties = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterData", vFilterData)) + _Component.StoreToURL(sFile, vProperties) + bSaved = True + +Finally: + ExportAsPDF = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEASERROR, "FileName", FileName, "Overwrite", Overwrite _ + , "FilterName", "PDF Export") + GoTo Finally +End Function ' SFDocuments.SF_Document.ExportAsPDF + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "SFDocuments.Document.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Document service as an array + + Methods = Array( _ + "Activate" _ + , "CloseDocument" _ + , "CreateMenu" _ + , "ExportAsPDF" _ + , "PrintOut" _ + , "RemoveMenu" _ + , "RunCommand" _ + , "Save" _ + , "SaveAs" _ + , "SaveCopyAs" _ + , "SetPrinter" _ + ) + +End Function ' SFDocuments.SF_Document.Methods + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + , Optional ByRef _Document As Variant _ + ) As Boolean +''' Send the content of the document to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' Args: +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' _Document: undocumented argument to designate the document to print when called from a subclass +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("1-4;10;15-18", Copies := 2) + +Dim bPrint As Boolean ' Return value +Dim vPrintGoal As Variant ' Array of property values + +Const cstThisSub = "SFDocuments.Document.PrintOut" +Const cstSubArgs = "[Pages=""""], [Copies=1]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + If IsMissing(_Document) Or IsEmpty(_Document) Or IsNull(_Document) Then Set _Document = _Component + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + End If + +Try: + vPrintGoal = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("CopyCount", CInt(Copies)) _ + , ScriptForge.SF_Utils._MakePropertyValue("Collate", True) _ + , ScriptForge.SF_Utils._MakePropertyValue("Pages", Pages) _ + , ScriptForge.SF_Utils._MakePropertyValue("Wait", False) _ + ) + + _Document.Print(vPrintGoal) + bPrint = True + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Document class as an array + + Properties = Array( _ + "CustomProperties" _ + , "Description" _ + , "DocumentProperties" _ + , "DocumentType" _ + , "ExportFilters" _ + , "ImportFilters" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw" _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "Keywords" _ + , "Readonly" _ + , "Subject" _ + , "Title" _ + , "XComponent" _ + ) + +End Function ' SFDocuments.SF_Document.Properties + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByRef _Document As Variant _ +) As Boolean +''' Remove a menu entry in the document's menubar +''' The removal is not intended to be saved neither in the LibreOffice global environment, nor in the document +''' Args: +''' MenuHeader: the name/header of the menu, without tilde "~", as a case-sensitive string +''' _Document: undocumented argument to designate the document where the menu is located +''' Returns: +''' True when successful +''' Examples: +''' oDoc.RemoveMenu("File") +''' ' ... + +Dim bRemove As Boolean ' Return value +Dim oLayout As Object ' com.sun.star.comp.framework.LayoutManager +Dim oMenuBar As Object ' com.sun.star.awt.XMenuBar or stardiv.Toolkit.VCLXMenuBar +Dim sName As String ' Menu name +Dim iMenuId As Integer ' Menu identifier +Dim iMenuPosition As Integer ' Menu position >= 0 +Dim i As Integer +Const cstTilde = "~" + +Const cstThisSub = "SFDocuments.Document.RemoveMenu" +Const cstSubArgs = "MenuHeader" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRemove = False + +Check: + If IsMissing(_Document) Or IsEmpty(_Document) Or IsNull(_Document) Then Set _Document = _Component + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(MenuHeader, "MenuHeader", V_STRING) Then GoTo Finally + End If + +Try: + Set oLayout = _Document.CurrentController.Frame.LayoutManager + Set oMenuBar = oLayout.getElement("private:resource/menubar/menubar").XMenuBar + + ' Search the menu identifier to remove by its name, Mark its position + With oMenuBar + iMenuPosition = -1 + For i = 0 To .ItemCount - 1 + iMenuId = .getItemId(i) + sName = Replace(.getItemText(iMenuId), cstTilde, "") + If MenuHeader= sName Then + iMenuPosition = i + Exit For + End If + Next i + ' Remove the found menu item + If iMenuPosition >= 0 Then + .removeItem(iMenuPosition, 1) + bRemove = True + End If + End With + +Finally: + RemoveMenu = bRemove + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) +''' Run on the current document window the given menu command. The command is executed with or without arguments +''' A few typical commands: +''' Save, SaveAs, ExportToPDF, SetDocumentProperties, Undo, Copy, Paste, ... +''' Dozens can be found on next page: https://wiki.documentfoundation.org/Development/DispatchCommands +''' Args: +''' Command: Case-sensitive. The command itself is not checked. +''' If the command does not contain the ".uno:" prefix, it is added. +''' If nothing happens, then the command is probably wrong +''' Args: Pairs of arguments name (string), value (any) +''' Returns: +''' Examples: +''' oDoc.RunCommand("EditDoc", "Editable", False) ' Toggle edit mode + +Dim vArgs As Variant ' Alias of Args +Dim oDispatch ' com.sun.star.frame.DispatchHelper +Dim vProps As Variant ' Array of PropertyValues +Dim vValue As Variant ' A single value argument +Dim sCommand As String ' Alias of Command +Dim i As Long +Const cstPrefix = ".uno:" + +Const cstThisSub = "SFDocuments.Document.RunCommand" +Const cstSubArgs = "Command, [arg0Name, arg0Value], [arg1Name, arg1Value], ..." + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + ' When called from a subclass (Calc, Writer, ..) the arguments are gathered into one single array item + vArgs = Args + If IsArray(Args) Then + If UBound(Args) >= 0 And IsArray(Args(0)) Then vArgs = Args(0) + End If + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Command, "Command", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._ValidateArray(vArgs, "Args", 1) Then GoTo Finally + For i = 0 To UBound(vArgs) - 1 Step 2 + If Not ScriptForge.SF_Utils._Validate(vArgs(i), "Arg" & CStr(i/2) & "Name", V_STRING) Then GoTo Finally + Next i + End If + +Try: + ' Build array of property values + vProps = Array() + For i = 0 To UBound(vArgs) - 1 Step 2 + If IsEmpty(vArgs(i + 1)) Then vValue = Null Else vValue = vArgs(i + 1) + vProps = ScriptForge.SF_Array.Append(vProps, ScriptForge.SF_Utils._MakePropertyValue(vArgs(i), vValue)) + Next i + Set oDispatch = ScriptForge.SF_Utils._GetUNOService("DispatchHelper") + If ScriptForge.SF_String.StartsWith(Command, cstPrefix) Then sCommand = Command Else sCommand = cstPrefix & Command + oDispatch.executeDispatch(_Frame, sCommand, "", 0, vProps) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +Catch: + GoTo Finally +End Sub ' SFDocuments.SF_Document.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean +''' Store the document to the file location from which it was loaded +''' Ignored if the document was not modified +''' Args: +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEERROR The file has been opened readonly or was opened as new and was not yet saved +''' Examples: +''' If Not oDoc.Save() Then +''' ' ... + +Dim bSaved As Boolean ' return value +Const cstThisSub = "SFDocuments.Document.Save" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSaved = False + +Check: + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + bSaved = False + +Try: + With _Component + If .isReadonly() Or Not .hasLocation() Then GoTo CatchReadonly + If .IsModified() Then + .store() + bSaved = True + End If + End With + +Finally: + Save = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchReadonly: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEERROR, "FileName", _FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Document.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean +''' Store the document to the given file location +''' The new location becomes the new file name on which simple Save method calls will be applied +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Password: Use to protect the document +''' FilterName: the name of a filter that should be used for saving the document +''' If present, the filter must exist +''' FilterOptions: an optional string of options associated with the filter +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEASERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.SaveAs("C:\Me\Copy2.odt", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Document.SaveAs" +Const cstSubArgs = "FileName, [Overwrite=False], [Password=""""], [FilterName=""""], [FilterOptions=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(FilterName) Or IsEmpty(FilterName) Then FilterName = "" + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterName, "FilterName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterOptions, "FilterOptions", V_STRING) Then GoTo Finally + End If + + ' Check that the filter exists + If Len(FilterName) > 0 Then + Set oFilterFactory = ScriptForge.SF_Utils._GetUNOService("FilterFactory") + If Not oFilterFactory.hasByName(FilterName) Then GoTo CatchError + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + If Len(Password) + Len(FilterName) = 0 Then + vProperties = Array() + Else + vProperties = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", FilterName) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterOptions", FilterOptions) _ + ) + If Len(Password) > 0 Then ' Password is to add only if <> "" !? + vProperties = ScriptForge.SF_Array.Append(vProperties _ + , ScriptForge.SF_Utils._MakePropertyValue("Password", Password)) + End If + End If + + _Component.StoreAsURL(sFile, vProperties) + + ' Remind the new file name + _WindowFileName = sFile + _WindowName = FSO.GetName(FileName) + bSaved = True + +Finally: + SaveAs = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEASERROR, "FileName", FileName, "Overwrite", Overwrite _ + , "FilterName", FilterName) + GoTo Finally +End Function ' SFDocuments.SF_Document.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean +''' Store a copy or export the document to the given file location +''' The actual location is unchanged +''' Args: +''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation +''' Overwrite: True if the destination file may be overwritten (default = False) +''' Password: Use to protect the document +''' FilterName: the name of a filter that should be used for saving the document +''' If present, the filter must exist +''' FilterOptions: an optional string of options associated with the filter +''' Returns: +''' False if the document could not be saved +''' Exceptions: +''' DOCUMENTSAVEASERROR The destination has its readonly attribute set or overwriting rejected +''' Examples: +''' oDoc.SaveCopyAs("C:\Me\Copy2.odt", Overwrite := True) + +Dim bSaved As Boolean ' return value +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess +Dim sFile As String ' Alias of FileName +Dim vProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim FSO As Object ' SF_FileSystem +Const cstThisSub = "SFDocuments.Document.SaveCopyAs" +Const cstSubArgs = "FileName, [Overwrite=False], [Password=""""], [FilterName=""""], [FilterOptions=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError + bSaved = False + +Check: + If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If IsMissing(FilterName) Or IsEmpty(FilterName) Then FilterName = "" + If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = "" + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally + If Not SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterName, "FilterName", V_STRING) Then GoTo Finally + If Not SF_Utils._Validate(FilterOptions, "FilterOptions", V_STRING) Then GoTo Finally + End If + + ' Check that the filter exists + If Len(FilterName) > 0 Then + Set oFilterFactory = ScriptForge.SF_Utils._GetUNOService("FilterFactory") + If Not oFilterFactory.hasByName(FilterName) Then GoTo CatchError + End If + + ' Check destination file overwriting + Set FSO = CreateScriptService("FileSystem") + sFile = FSO._ConvertToUrl(FileName) + If FSO.FileExists(FileName) Then + If Overwrite = False Then GoTo CatchError + Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") + If oSfa.isReadonly(sFile) Then GoTo CatchError + End If + +Try: + ' Setup arguments + If Len(Password) + Len(FilterName) = 0 Then + vProperties = Array() + Else + vProperties = Array( _ + ScriptForge.SF_Utils._MakePropertyValue("FilterName", FilterName) _ + , ScriptForge.SF_Utils._MakePropertyValue("FilterOptions", FilterOptions) _ + ) + If Len(Password) > 0 Then ' Password is to add only if <> "" !? + vProperties = ScriptForge.SF_Array.Append(vProperties _ + , ScriptForge.SF_Utils._MakePropertyValue("Password", Password)) + End If + End If + + _Component.StoreToURL(sFile, vProperties) + bSaved = True + +Finally: + SaveCopyAs = bSaved + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchError: + ScriptForge.SF_Exception.RaiseFatal(DOCUMENTSAVEASERROR, "FileName", FileName, "Overwrite", Overwrite _ + , "FilterName", FilterName) + GoTo Finally +End Function ' SFDocuments.SF_Document.SaveCopyAs + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + , Optional ByRef _PrintComponent As Variant _ + ) As Boolean +''' Define the printer options for the document +''' Args: +''' Printer: the name of the printer queue where to print to +''' When absent or space, the default printer is set +''' Orientation: either "PORTRAIT" or "LANDSCAPE". Left unchanged when absent +''' PaperFormat: one of next values +''' "A3", "A4", "A5", "B4", "B5", "LETTER", "LEGAL", "TABLOID" +''' Left unchanged when absent +''' _PrintComponent: undocumented argument to determine the component +''' Useful typically to apply printer settings on a Base form document +''' Returns: +''' True when successful +''' Examples: +''' oDoc.SetPrinter(Orientation := "PORTRAIT") + +Dim bPrinter As Boolean ' Return value +Dim vPrinters As Variant ' Array of known printers +Dim vOrientations As Variant ' Array of allowed paper orientations +Dim vPaperFormats As Variant ' Array of allowed formats +Dim vPrinterSettings As Variant ' Array of property values +Dim oPropertyValue As New com.sun.star.beans.PropertyValue + ' A single property value item +Const cstThisSub = "SFDocuments.Document.SetPrinter" +Const cstSubArgs = "[Printer=""""], [Orientation=""PORTRAIT""|""LANDSCAPE""]" _ + & ", [PaperFormat=""A3""|""A4""|""A5""|""B4""|""B5""|""LETTER""|""LEGAL""|""TABLOID""" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrinter = False + +Check: + If IsMissing(Printer) Or IsEmpty(Printer) Then Printer = "" + If IsMissing(Orientation) Or IsEmpty(Orientation) Then Orientation = "" + If IsMissing(PaperFormat) Or IsEmpty(PaperFormat) Then PaperFormat = "" + If IsMissing(_PrintComponent) Or IsEmpty(_PrintComponent) Then Set _PrintComponent = _Component + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional validation + If Not _IsStillAlive() Then GoTo Finally + If VarType(Printer) = V_STRING Then + vPrinters = ScriptForge.SF_Platform.Printers + If Len(Printer) > 0 Then + If Not ScriptForge.SF_Utils._Validate(Printer, "Printer", V_STRING, vPrinters) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(Printer, "Printer", V_STRING) Then GoTo Finally ' Manage here the VarType error + End If + If VarType(Orientation) = V_STRING Then + vOrientations = Array("PORTRAIT", "LANDSCAPE") + If Len(Orientation) > 0 Then + If Not ScriptForge.SF_Utils._Validate(Orientation, "Orientation", V_STRING, vOrientations) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(Orientation, "Orientation", V_STRING) Then GoTo Finally + End If + If VarType(PaperFormat) = V_STRING Then + vPaperFormats = Array("A3", "A4", "A5", "B4", "B5", "LETTER", "LEGAL", "TABLOID") + If Len(PaperFormat) > 0 Then + If Not ScriptForge.SF_Utils._Validate(PaperFormat, "PaperFormat", V_STRING, vPaperFormats) Then GoTo Finally + End If + Else + If Not ScriptForge.SF_Utils._Validate(PaperFormat, "PaperFormat", V_STRING) Then GoTo Finally + End If + +Try: + With _PrintComponent + Set oPropertyValue = ScriptForge.SF_Utils._MakePropertyValue("Name", Iif(Len(Printer) > 0, Printer, vPrinters(0))) + vPrinterSettings = Array(oPropertyValue) + If Len(Orientation) > 0 Then + vPrinterSettings = ScriptForge.SF_Utils._SetPropertyValue(vPrinterSettings, "PaperOrientation" _ + , ScriptForge.SF_Array.IndexOf(vOrientations, Orientation, CaseSensitive := False)) + End If + If Len(PaperFormat) > 0 Then + vPrinterSettings = ScriptForge.SF_Utils._SetPropertyValue(vPrinterSettings, "PaperFormat" _ + , ScriptForge.SF_Array.IndexOf(vPaperFormats, PaperFormat, CaseSensitive := False)) + End If + .setPrinter(vPrinterSettings) + End With + bPrinter = True + +Finally: + SetPrinter = bPrinter + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.SetPrinter + +REM ----------------------------------------------------------------------------- +Private Function SetProperty(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Document.set" & psProperty + If IsMissing(pvValue) Then pvValue = Empty + 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("CustomProperties") + CustomProperties = pvValue + Case UCase("Description") + Description = pvValue + Case UCase("Keywords") + Keywords = pvValue + Case UCase("Subject") + Subject = pvValue + Case UCase("Title") + Title = pvValue + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Document.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = Iif(Len(_WindowFileName) > 0, SF_FileSystem._ConvertFromUrl(_WindowFileName), _WindowTitle) + +End Function ' SFDocuments.SF_Document._FileIdent + +REM ----------------------------------------------------------------------------- +Private Function _GetFilterNames(ByVal pbExport As Boolean) As Variant +''' Returns the list of export (pbExport = True) or import filters +''' applicable to the current document +''' Args: +''' pbExport: True for export, False for import +''' Returns: +''' A zero-based array of strings + +Dim vFilters As Variant ' Return value +Dim sIdentifier As String ' Document service, like com.sun.star.text.TextDocument +Dim oFilterFactory As Object ' com.sun.star.document.FilterFactory +Dim vAllFilters As Variant ' The full list of installed filters +Dim sFilter As String ' A single filter name +Dim iCount As Integer ' Filters counter +Dim vFilter As Variant ' A filter descriptor as an array of Name/Value pairs +Dim sType As String ' The filter type to be compared with the document service +Dim lFlags As Long ' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Office_Development#Properties_of_a_Filter +Dim bExport As Boolean ' Filter valid for export when True +Dim bImport As Boolean ' Filter valid for import when True +Dim bImportExport As Boolean ' Filter valid both for import and export when True + + vFilters = Array() + On Local Error GoTo Finally ' Return empty or partial list if error + +Try: + sIdentifier = _Component.Identifier + Set oFilterFactory = ScriptForge.SF_Utils._GetUNOService("FilterFactory") + vAllFilters = oFilterFactory.getElementNames() + ReDim vFilters(0 To UBound(vAllFilters)) + iCount = -1 + + For Each sFilter In vAllFilters + vFilter = oFilterFactory.getByName(sFilter) + sType = vFilter(12).Value ' Hard-coded index for document types + If sType = sIdentifier Then + lFlags = vFilter(10).Value ' Hard-coded index for flags + ' export: flag is even + ' import: flag is odd and flag/2 is even + ' import/export: flag is odd and flag/2 is odd + bExport = ( lFlags Mod 2 = 0 ) + bImport = ( (lFlags Mod 2 = 1) And ((lFlags \ 2) Mod 2 = 0) ) + bImportExport = ( (lFlags Mod 2 = 1) And ((lFlags \ 2) Mod 2 = 1) ) + ' Select filter ? + If bImportExport _ + Or (pbExport And bExport) _ + Or (Not pbExport And bImport) Then + iCount = iCount + 1 + vFilters(iCount) = sFilter + End If + End If + Next sFilter + + If iCount > -1 Then + ReDim Preserve vFilters(0 To iCount) + End If + +Finally: + _GetFilterNames = vFilters + Exit Function +End Function ' SFDocuments.SF_Document._GetFilterNames + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value +Dim sFileName As String ' File identification used to display error message + + On Local Error GoTo Catch ' Anticipate DisposedException errors or alike + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + ' Check existence of document + bAlive = Not IsNull(_Frame) + If bAlive Then bAlive = Not IsNull(_Component) + If bAlive Then bAlive = Not IsNull(_Component.CurrentController) + + ' Check document is not read only + If bAlive And pbForUpdate Then + If _Component.isreadonly() Then GoTo CatchReadonly + End If + +Finally: + _IsStillAlive = bAlive + Exit Function +Catch: + bAlive = False + On Error GoTo 0 + sFileName = _FileIdent() + Dispose() + If pbError Then ScriptForge.SF_Exception.RaiseFatal(DOCUMENTDEADERROR, sFileName) + GoTo Finally +CatchReadonly: + bAlive = False + If pbError Then ScriptForge.SF_Exception.RaiseFatal(DOCUMENTREADONLYERROR, "Document", _FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Document._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Sub _LoadDocumentProperties() +''' Create dictionary with document properties as entries/ Custom properties are excluded +''' Document is presumed still alive +''' Special values: +''' Only valid dates are taken +''' Statistics are exploded in subitems. Subitems are specific to document type +''' Keywords are joined +''' Language is aligned on L10N convention la-CO + +Dim oProperties As Object ' Document properties +Dim vNamedValue As Variant ' com.sun.star.beans.NamedValue + + If IsNull(_DocumentProperties) Then + Set oProperties = _Component.getDocumentProperties + Set _DocumentProperties = CreateScriptService("Dictionary") + With _DocumentProperties + .Add("Author", oProperties.Author) + .Add("AutoloadSecs", oProperties.AutoloadSecs) + .Add("AutoloadURL", oProperties.AutoloadURL) + If oProperties.CreationDate.Year > 0 Then .Add("CreationDate", CDateFromUnoDateTime(oProperties.CreationDate)) + .Add("DefaultTarget", oProperties.DefaultTarget) + .Add("Description", oProperties.Description) ' The description can be multiline + ' DocumentStatistics : number and names of statistics depend on document type + For Each vNamedValue In oProperties.DocumentStatistics + .Add(vNamedValue.Name, vNamedValue.Value) + Next vNamedValue + .Add("EditingDuration", oProperties.EditingDuration) + .Add("Generator", oProperties.Generator) + .Add("Keywords", Join(oProperties.Keywords, ", ")) + .Add("Language", oProperties.Language.Language & Iif(Len(oProperties.Language.Country) > 0, "-" & oProperties.Language.Country, "")) + If oProperties.ModificationDate.Year > 0 Then .Add("ModificationDate", CDateFromUnoDateTime(oProperties.ModificationDate)) + If oProperties.PrintDate.Year > 0 Then .Add("PrintDate", CDateFromUnoDateTime(oProperties.PrintDate)) + .Add("PrintedBy", oProperties.PrintedBy) + .Add("Subject", oProperties.Subject) + If oProperties.TemplateDate.Year > 0 Then .Add("TemplateDate", CDateFromUnoDateTime(oProperties.TemplateDate)) + .Add("TemplateName", oProperties.TemplateName) + .Add("TemplateURL", oProperties.TemplateURL) + .Add("Title", oProperties.Title) + End With + End If + +End Sub ' SFDocuments.SF_Document._LoadDocumentProperties + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim oProperties As Object ' Document or Custom properties +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + Select Case _DocumentType + Case "Calc" : cstThisSub = "SFDocuments.SF_" & _DocumentType & ".get" & psProperty + Case Else : cstThisSub = "SFDocuments.SF_Document.get" & psProperty + End Select + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case psProperty + Case "CustomProperties" + _CustomProperties = CreateScriptService("Dictionary") ' Always reload as updates could have been done manually by user + _CustomProperties.ImportFromPropertyValues(_Component.getDocumentProperties().UserDefinedProperties.getPropertyValues) + _PropertyGet = _CustomProperties + Case "Description" + _PropertyGet = _Component.DocumentProperties.Description + Case "DocumentProperties" + _LoadDocumentProperties() ' Always reload as updates could have been done manually by user + Set _PropertyGet = _DocumentProperties + Case "DocumentType" + _PropertyGet = _DocumentType + Case "ExportFilters" + _PropertyGet = _GetFilterNames(True) + Case "ImportFilters" + _PropertyGet = _GetFilterNames(False) + Case "IsBase", "IsCalc", "IsDraw", "IsImpress", "IsMath", "IsWriter" + _PropertyGet = ( Mid(psProperty, 3) = _DocumentType ) + Case "Keywords" + _PropertyGet = Join(_Component.DocumentProperties.Keywords, ", ") + Case "Readonly" + _PropertyGet = _Component.isReadonly() + Case "Subject" + _PropertyGet = _Component.DocumentProperties.Subject + Case "Title" + _PropertyGet = _Component.DocumentProperties.Title + Case "XComponent" + Set _PropertyGet = _Component + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Document._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Document instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DOCUMENT]: Type - File" + + _Repr = "[Document]: " & _DocumentType & " - " & _FileIdent() + +End Function ' SFDocuments.SF_Document._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_DOCUMENT + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_DocumentListener.xba b/wizards/source/sfdocuments/SF_DocumentListener.xba new file mode 100644 index 000000000..fbb0271bb --- /dev/null +++ b/wizards/source/sfdocuments/SF_DocumentListener.xba @@ -0,0 +1,114 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_DocumentListener +''' =================== +''' The current module is dedicated to the management of document events + listeners, triggered by user actions, +''' which cannot be defined with the Basic IDE +''' +''' Concerned listeners: +''' com.sun.star.sheet.XRangeSelectionListener +''' allowing a user to select a cell range at any moment +''' +''' The described events/listeners are processed by UNO listeners +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================= DEFINITIONS + +REM ============================================================= PRIVATE MEMBERS + +Private _SelectedRange As String ' The selected range is returned by a "done" event +Private _RangeSelectionFinished As Boolean ' Flag indicating that the interaction with the user has stopped + +REM ================================================================== EXCEPTIONS + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Function RunRangeSelector(ByRef poComponent As Object _ + , ByRef pvPropertyValues As Variant _ + ) As String +''' Called from the SF_Calc.OpenRangeSelector() method +''' Opens a non-modal dialog with a text box, +''' let the user make a selection in the current or another sheet and +''' returns the selected area as a string. + +Dim oController As Object ' com.sun.star.frame.Controller +Dim oListener As Object ' com.sun.star.sheet.XRangeSelectionListener +Dim lCountLoops As Long ' Sleep cycles counter + +Const cstListenerPrefix = "_SFRGSEL_" ' Prefix used for naming events Subs +Const cstSleep = 50 ' Sleep steps in ms while waiting for the end of the interaction +Const cstMaxSleep = (60 * 5 * 1000) / cstSleep ' Never sleep more than 5 minutes. Afterwards, processing continues + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + ' Create the listener + Set oController = poComponent.CurrentController + Set oListener = CreateUnoListener(cstListenerPrefix, "com.sun.star.sheet.XRangeSelectionListener") + oController.addRangeSelectionListener(oListener) + + ' Open the selector + _SelectedRange = "" + _RangeSelectionFinished = False + oController.startRangeSelection(pvPropertyValues) + + ' Dummy thread synchronization + lCountLoops = 0 + Do While Not _RangeSelectionFinished And lCountLoops < cstMaxSleep + Wait(cstSleep) + lCountLoops = lCountLoops + 1 + Loop + +Finally: + If Not IsNull(oListener) Then oController.removeRangeSelectionListener(oListener) + RunRangeSelector = _SelectedRange + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_DocumentListener.RunRangeSelector + +REM ============================================================= PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Sub _SFRGSEL_done(Optional poEvent As Object) ' com.sun.star.sheet.RangeSelectionEvent + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + _SelectedRange = poEvent.RangeDescriptor + _RangeSelectionFinished = True + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub + +REM ----------------------------------------------------------------------------- +Sub _SFRGSEL_aborted(Optional poEvent As Object) ' com.sun.star.sheet.RangeSelectionEvent + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + _RangeSelectionFinished = True + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub + +REM ============================================ END OF SFDIALOGS.SF_DIALOGLISTENER + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Form.xba b/wizards/source/sfdocuments/SF_Form.xba new file mode 100644 index 000000000..404c24bd3 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Form.xba @@ -0,0 +1,1535 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Form +''' ======= +''' Management of forms defined in LibreOffice documents. Supported types are Base, Calc and Writer documents. +''' It includes the management of subforms +''' Each instance of the current class represents a single form or a single subform +''' +''' A form may optionally be (understand "is often") linked to a data source manageable with the SFDatabases.Database service +''' The current service offers a rapid access to that service +''' +''' Definitions: +''' +''' FormDocument: +''' For usual documents, there is only 1 form document. It is in fact the document itself. +''' A Base document may contain an unlimited number of form documents. +''' In the Base terminology they are called "forms" or "Base forms". This could create some confusion. +''' They can be organized in folders. Their name is then always the full path of folders + form +''' with the slash ("/") as path separator +''' A FormDocument is a set of Forms. Form names are visible in the user interface thanks to the form navigator +''' Often there is only 1 Form present in a FormDocument. Having more, however, might improve +''' the user experience significantly +''' +''' Form: WHERE IT IS ABOUT IN THE CURRENT "Form" SERVICE +''' Is an abstract set of Controls in an OPEN FormDocument +''' Each form is usually linked to one single dataset (table, query or Select statement), +''' located in any database (provided the user may access it) +''' A usual document may contain several forms. Each of which may have its own data source (database + dataset) +''' A Base form document may contain several forms. Each of which may address its own dataset. The database however is unique +''' A form is defined by its owning FormDocument and its FormName or FormIndex +''' +''' Service invocations: +''' +''' REM the form is stored in a not-Base document (Calc, Writer) +''' Dim oDoc As Object, myForm As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", ThisComponent) +''' Set myForm = oDoc.Forms("Form1") +''' ' or, alternatively, when there is only 1 form +''' Set myForm = oDoc.Forms(0) +''' +''' REM the form is stored in one of the FormDocuments of a Base document +''' Dim oDoc As Object, myForm As Object, mySubForm As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", ThisDatabaseDocument) +''' oDoc.OpenFormDocument("thisFormDocument") +''' Set myForm = oDoc.Forms("thisFormDocument", "MainForm") +''' ' or, alternatively, when there is only 1 form +''' Set myForm = oDoc.Forms("thisFormDocument", 0) +''' ' To access a subform: myForm and mySubForm become distinct instances of the current class +''' Set mySubForm = myForm.SubForms("mySubForm") +''' +''' REM the form is the subject of an event +''' Sub OnEvent(ByRef poEvent As Object) +''' Dim myForm As Object +''' Set myForm = CreateScriptService("SFDocuments.FormEvent", poEvent) +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_form.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const FORMDEADERROR = "FORMDEADERROR" +Private Const SUBFORMNOTFOUNDERROR = "SUBFORMNOTFOUNDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be Form +Private ServiceName As String + +' Form location +Private _Name As String ' Internal name of the form +Private _FormType As Integer ' One of the ISxxxFORM constants +Private _SheetName As String ' Name as the sheet containing the form (Calc only) +Private _FormDocumentName As String ' The hierarchical name of the containing form document (Base only) +Private _FormDocument As Object ' com.sun.star.comp.sdb.Content - the containing form document + ' The form topmost container +Private _Component As Object ' com.sun.star.lang.XComponent or com.sun.star.comp.dba.ODatabaseDocument + +' Events management +Private _CacheIndex As Long ' Index in central cache storage + +' Form UNO references +' The entry to the interactions with the form. Validity checked by the _IsStillAlive() method +' Each method or property requiring that the form is opened should first invoke that method +Private _Form As Object ' com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +Private _Database As Object ' Database class instance + +' Form attributes + +' Cache storage for controls +Private _ControlNames As Variant ' Array of control names +Private _ControlCache As Variant ' Array of control objects sorted like ElementNames of XForm + +REM ============================================================ MODULE CONSTANTS + +Const ISDOCFORM = 1 ' Form is stored in a Writer document +Const ISCALCFORM = 2 ' Form is stored in a Calc document +Const ISBASEFORM = 3 ' Form is stored in a Base document +Const ISSUBFORM = 4 ' Form is a subform of a form or of another subform +Const ISUNDEFINED = -1 ' Undefined form type + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "FORM" + ServiceName = "SFDocuments.Form" + _Name = "" + _SheetName = "" + _FormDocumentName = "" + Set _FormDocument = Nothing + _FormType = ISUNDEFINED + _CacheIndex = -1 + Set _Form = Nothing + Set _Database = Nothing + _ControlNames = Array() + _ControlCache = Array() +End Sub ' SFDocuments.SF_Form Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Form Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull(_Database) And (_FormType = ISDOCFORM Or _FormType = ISCALCFORM) Then + Set _Database = _Database.Dispose() + End If + SF_Register._CleanCacheEntry(_CacheIndex) + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Form Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get AllowDeletes() As Variant +''' The AllowDeletes property specifies if the form allows to delete records + AllowDeletes = _PropertyGet("AllowDeletes") +End Property ' SFDocuments.SF_Form.AllowDeletes (get) + +REM ----------------------------------------------------------------------------- +Property Let AllowDeletes(Optional ByVal pvAllowDeletes As Variant) +''' Set the updatable property AllowDeletes + _PropertySet("AllowDeletes", pvAllowDeletes) +End Property ' SFDocuments.SF_Form.AllowDeletes (let) + +REM ----------------------------------------------------------------------------- +Property Get AllowInserts() As Variant +''' The AllowInserts property specifies if the form allows to add records + AllowInserts = _PropertyGet("AllowInserts") +End Property ' SFDocuments.SF_Form.AllowInserts (get) + +REM ----------------------------------------------------------------------------- +Property Let AllowInserts(Optional ByVal pvAllowInserts As Variant) +''' Set the updatable property AllowInserts + _PropertySet("AllowInserts", pvAllowInserts) +End Property ' SFDocuments.SF_Form.AllowInserts (let) + +REM ----------------------------------------------------------------------------- +Property Get AllowUpdates() As Variant +''' The AllowUpdates property specifies if the form allows to update records + AllowUpdates = _PropertyGet("AllowUpdates") +End Property ' SFDocuments.SF_Form.AllowUpdates (get) + +REM ----------------------------------------------------------------------------- +Property Let AllowUpdates(Optional ByVal pvAllowUpdates As Variant) +''' Set the updatable property AllowUpdates + _PropertySet("AllowUpdates", pvAllowUpdates) +End Property ' SFDocuments.SF_Form.AllowUpdates (let) + +REM ----------------------------------------------------------------------------- +Property Get BaseForm() As String +''' The BaseForm property specifies the hierarchical name of the Base form containing the actual form + BaseForm = _PropertyGet("BaseForm") +End Property ' SFDocuments.SF_Form.BaseForm (get) + +REM ----------------------------------------------------------------------------- +Property Get Bookmark() As Variant +''' The Bookmark property specifies uniquely the current record of the form's underlying table, query or SQL statement. + Bookmark = _PropertyGet("Bookmark") +End Property ' SFDocuments.SF_Form.Bookmark (get) + +REM ----------------------------------------------------------------------------- +Property Let Bookmark(Optional ByVal pvBookmark As Variant) +''' Set the updatable property Bookmark + _PropertySet("Bookmark", pvBookmark) +End Property ' SFDocuments.SF_Form.Bookmark (let) + +REM ----------------------------------------------------------------------------- +Property Get CurrentRecord() As Variant +''' The CurrentRecord property identifies the current record in the recordset being viewed on a form + CurrentRecord = _PropertyGet("CurrentRecord") +End Property ' SFDocuments.SF_Form.CurrentRecord (get) + +REM ----------------------------------------------------------------------------- +Property Let CurrentRecord(Optional ByVal pvCurrentRecord As Variant) +''' Set the updatable property CurrentRecord +''' If the row number is positive, the cursor moves to the given row number with respect to the beginning of the result set. +''' The first row is row 1, the second is row 2, and so on. +''' If the given row number is negative, the cursor moves to an absolute row position with respect to the end of the result set. +''' For example, setting CurrentRecord = -1 positions the cursor on the last row, -2 indicates the next-to-last row, and so on + _PropertySet("CurrentRecord", pvCurrentRecord) +End Property ' SFDocuments.SF_Form.CurrentRecord (let) + +REM ----------------------------------------------------------------------------- +Property Get Filter() As Variant +''' The Filter property specifies a subset of records to be displayed. + Filter = _PropertyGet("Filter") +End Property ' SFDocuments.SF_Form.Filter (get) + +REM ----------------------------------------------------------------------------- +Property Let Filter(Optional ByVal pvFilter As Variant) +''' Set the updatable property Filter + _PropertySet("Filter", pvFilter) +End Property ' SFDocuments.SF_Form.Filter (let) + +REM ----------------------------------------------------------------------------- +Property Get LinkChildFields() As Variant +''' The LinkChildFields property specifies how records in a subform (child) are linked to records in its parent form +''' It returns an array of strings + LinkChildFields = _PropertyGet("LinkChildFields") +End Property ' SFDocuments.SF_Form.LinkChildFields (get) + +REM ----------------------------------------------------------------------------- +Property Get LinkParentFields() As Variant +''' The LinkParentFields property specifies how records in a subform (Child) are linked to records in its parent form +''' It returns an array of strings + LinkParentFields = _PropertyGet("LinkParentFields") +End Property ' SFDocuments.SF_Form.LinkParentFields (get) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual Form + Name = _PropertyGet("Name") +End Property ' SFDocuments.SF_Form.Name + +REM ----------------------------------------------------------------------------- +Property Get OnApproveCursorMove() As Variant +''' The OnApproveCursorMove property specifies the script to trigger when this event occurs + OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") +End Property ' SFDocuments.SF_Form.OnApproveCursorMove (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveCursorMove(Optional ByVal pvOnApproveCursorMove As Variant) +''' Set the updatable property OnApproveCursorMove + _PropertySet("OnApproveCursorMove", pvOnApproveCursorMove) +End Property ' SFDocuments.SF_Form.OnApproveCursorMove (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant +''' The OnApproveReset property specifies the script to trigger when this event occurs + OnApproveReset = _PropertyGet("OnApproveReset") +End Property ' SFDocuments.SF_Form.OnApproveReset (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveReset(Optional ByVal pvOnApproveReset As Variant) +''' Set the updatable property OnApproveReset + _PropertySet("OnApproveReset", pvOnApproveReset) +End Property ' SFDocuments.SF_Form.OnApproveReset (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveRowChange() As Variant +''' The OnApproveRowChange property specifies the script to trigger when this event occurs + OnApproveRowChange = _PropertyGet("OnApproveRowChange") +End Property ' SFDocuments.SF_Form.OnApproveRowChange (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveRowChange(Optional ByVal pvOnApproveRowChange As Variant) +''' Set the updatable property OnApproveRowChange + _PropertySet("OnApproveRowChange", pvOnApproveRowChange) +End Property ' SFDocuments.SF_Form.OnApproveRowChange (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveSubmit() As Variant +''' The OnApproveSubmit property specifies the script to trigger when this event occurs + OnApproveSubmit = _PropertyGet("OnApproveSubmit") +End Property ' SFDocuments.SF_Form.OnApproveSubmit (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveSubmit(Optional ByVal pvOnApproveSubmit As Variant) +''' Set the updatable property OnApproveSubmit + _PropertySet("OnApproveSubmit", pvOnApproveSubmit) +End Property ' SFDocuments.SF_Form.OnApproveSubmit (let) + +REM ----------------------------------------------------------------------------- +Property Get OnConfirmDelete() As Variant +''' The OnConfirmDelete property specifies the script to trigger when this event occurs + OnConfirmDelete = _PropertyGet("OnConfirmDelete") +End Property ' SFDocuments.SF_Form.OnConfirmDelete (get) + +REM ----------------------------------------------------------------------------- +Property Let OnConfirmDelete(Optional ByVal pvOnConfirmDelete As Variant) +''' Set the updatable property OnConfirmDelete + _PropertySet("OnConfirmDelete", pvOnConfirmDelete) +End Property ' SFDocuments.SF_Form.OnConfirmDelete (let) + +REM ----------------------------------------------------------------------------- +Property Get OnCursorMoved() As Variant +''' The OnCursorMoved property specifies the script to trigger when this event occurs + OnCursorMoved = _PropertyGet("OnCursorMoved") +End Property ' SFDocuments.SF_Form.OnCursorMoved (get) + +REM ----------------------------------------------------------------------------- +Property Let OnCursorMoved(Optional ByVal pvOnCursorMoved As Variant) +''' Set the updatable property OnCursorMoved + _PropertySet("OnCursorMoved", pvOnCursorMoved) +End Property ' SFDocuments.SF_Form.OnCursorMoved (let) + +REM ----------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant +''' The OnErrorOccurred property specifies the script to trigger when this event occurs + OnErrorOccurred = _PropertyGet("OnErrorOccurred") +End Property ' SFDocuments.SF_Form.OnErrorOccurred (get) + +REM ----------------------------------------------------------------------------- +Property Let OnErrorOccurred(Optional ByVal pvOnErrorOccurred As Variant) +''' Set the updatable property OnErrorOccurred + _PropertySet("OnErrorOccurred", pvOnErrorOccurred) +End Property ' SFDocuments.SF_Form.OnErrorOccurred (let) + +REM ----------------------------------------------------------------------------- +Property Get OnLoaded() As Variant +''' The OnLoaded property specifies the script to trigger when this event occurs + OnLoaded = _PropertyGet("OnLoaded") +End Property ' SFDocuments.SF_Form.OnLoaded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnLoaded(Optional ByVal pvOnLoaded As Variant) +''' Set the updatable property OnLoaded + _PropertySet("OnLoaded", pvOnLoaded) +End Property ' SFDocuments.SF_Form.OnLoaded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnReloaded() As Variant +''' The OnReloaded property specifies the script to trigger when this event occurs + OnReloaded = _PropertyGet("OnReloaded") +End Property ' SFDocuments.SF_Form.OnReloaded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnReloaded(Optional ByVal pvOnReloaded As Variant) +''' Set the updatable property OnReloaded + _PropertySet("OnReloaded", pvOnReloaded) +End Property ' SFDocuments.SF_Form.OnReloaded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnReloading() As Variant +''' The OnReloading property specifies the script to trigger when this event occurs + OnReloading = _PropertyGet("OnReloading") +End Property ' SFDocuments.SF_Form.OnReloading (get) + +REM ----------------------------------------------------------------------------- +Property Let OnReloading(Optional ByVal pvOnReloading As Variant) +''' Set the updatable property OnReloading + _PropertySet("OnReloading", pvOnReloading) +End Property ' SFDocuments.SF_Form.OnReloading (let) + +REM ----------------------------------------------------------------------------- +Property Get OnResetted() As Variant +''' The OnResetted property specifies the script to trigger when this event occurs + OnResetted = _PropertyGet("OnResetted") +End Property ' SFDocuments.SF_Form.OnResetted (get) + +REM ----------------------------------------------------------------------------- +Property Let OnResetted(Optional ByVal pvOnResetted As Variant) +''' Set the updatable property OnResetted + _PropertySet("OnResetted", pvOnResetted) +End Property ' SFDocuments.SF_Form.OnResetted (let) + +REM ----------------------------------------------------------------------------- +Property Get OnRowChanged() As Variant +''' The OnRowChanged property specifies the script to trigger when this event occurs + OnRowChanged = _PropertyGet("OnRowChanged") +End Property ' SFDocuments.SF_Form.OnRowChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnRowChanged(Optional ByVal pvOnRowChanged As Variant) +''' Set the updatable property OnRowChanged + _PropertySet("OnRowChanged", pvOnRowChanged) +End Property ' SFDocuments.SF_Form.OnRowChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnUnloaded() As Variant +''' The OnUnloaded property specifies the script to trigger when this event occurs + OnUnloaded = _PropertyGet("OnUnloaded") +End Property ' SFDocuments.SF_Form.OnUnloaded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnUnloaded(Optional ByVal pvOnUnloaded As Variant) +''' Set the updatable property OnUnloaded + _PropertySet("OnUnloaded", pvOnUnloaded) +End Property ' SFDocuments.SF_Form.OnUnloaded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnUnloading() As Variant +''' The OnUnloading property specifies the script to trigger when this event occurs + OnUnloading = _PropertyGet("OnUnloading") +End Property ' SFDocuments.SF_Form.OnUnloading (get) + +REM ----------------------------------------------------------------------------- +Property Let OnUnloading(Optional ByVal pvOnUnloading As Variant) +''' Set the updatable property OnUnloading + _PropertySet("OnUnloading", pvOnUnloading) +End Property ' SFDocuments.SF_Form.OnUnloading (let) + +REM ----------------------------------------------------------------------------- +Property Get OrderBy() As Variant +''' The OrderBy property specifies in which order the records should be displayed. + OrderBy = _PropertyGet("OrderBy") +End Property ' SFDocuments.SF_Form.OrderBy (get) + +REM ----------------------------------------------------------------------------- +Property Let OrderBy(Optional ByVal pvOrderBy As Variant) +''' Set the updatable property OrderBy + _PropertySet("OrderBy", pvOrderBy) +End Property ' SFDocuments.SF_Form.OrderBy (let) + +REM ----------------------------------------------------------------------------- +Property Get Parent() As Object +''' Return the Parent of the actual Form + Parent = _PropertyGet("Parent") +End Property ' SFDocuments.SF_Form.Parent + +REM ----------------------------------------------------------------------------- +Property Get RecordSource() As Variant +''' The RecordSource property specifies the source of the data, +''' a table name, a query name or a SQL statement + RecordSource = _PropertyGet("RecordSource") +End Property ' SFDocuments.SF_Form.RecordSource (get) + +REM ----------------------------------------------------------------------------- +Property Let RecordSource(Optional ByVal pvRecordSource As Variant) +''' Set the updatable property RecordSource + _PropertySet("RecordSource", pvRecordSource) +End Property ' SFDocuments.SF_Form.RecordSource (let) + +REM ----------------------------------------------------------------------------- +Property Get XForm() As Object +''' The XForm property returns the XForm UNO object of the Form + XForm = _PropertyGet("XForm") +End Property ' SFDocuments.SF_Form.XForm (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean +''' Set the focus on the current Form instance +''' Probably called from after an event occurrence or to focus on an open Base form document +''' If the parent document is ... +''' Calc Activate the corresponding sheet +''' Writer Activate the parent document +''' Base Activate the parent form document +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' myForm.Activate() + +Dim bActivate As Boolean ' Return value +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDocuments.Form.Activate" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bActivate = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + Select Case _FormType + Case ISDOCFORM : bActivate = [_Parent].Activate() + Case ISCALCFORM : bActivate = [_Parent].Activate(_SheetName) + Case ISBASEFORM + Set oContainer = _FormDocument.Component.CurrentController.Frame.ContainerWindow + With oContainer + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .toFront() ' Force window change in Linux + Wait 1 ' Bypass desynchro issue in Linux + End With + bActivate = True + End Select + +Finally: + Activate = bActivate + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseFormDocument() As Boolean +''' Close the form document containing the actual form instance +''' The form instance is disposed +''' The method does nothing if the actual form is not located in a Base form document +''' Args: +''' Returns: +''' True if closure is successful +''' Example: +''' myForm.CloseFormDocument() + +Dim bClose As Boolean ' Return value +Dim oContainer As Object ' com.sun.star.awt.XWindow +Const cstThisSub = "SFDocuments.Form.CloseFormDocument" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bClose = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + Select Case _FormType + Case ISDOCFORM, ISCALCFORM, ISSUBFORM + Case ISBASEFORM + _FormDocument.close() + Dispose() + bClose = True + End Select + +Finally: + CloseFormDocument = bClose + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.CloseFormDocument + +REM ----------------------------------------------------------------------------- +Public Function Controls(Optional ByVal ControlName As Variant) As Variant +''' Return either +''' - the list of the controls contained in the Form +''' - a Form control object based on its name +''' Args: +''' ControlName: a valid control name as a case-sensitive string. If absent the list is returned +''' Returns: +''' A zero-base array of strings if ControlName is absent +''' An instance of the SF_FormControl class if ControlName exists +''' Exceptions: +''' ControlName is invalid +''' Example: +''' Dim myForm As Object, myList As Variant, myControl As Object +''' Set myForm = myDoc.Forms("myForm") +''' myList = myForm.Controls() +''' Set myControl = myForm.Controls("myTextBox") + +Dim oControl As Object ' The new control class instance +Dim lIndexOfNames As Long ' Index in ElementNames array. Used to access _ControlCache +Dim vControl As Variant ' Alias of _ControlCache entry +Dim i As Long +Const cstThisSub = "SFDocuments.Form.Controls" +Const cstSubArgs = "[ControlName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(ControlName) Or IsEmpty(ControlName) Then ControlName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING) Then GoTo Finally + End If + +Try: + ' Collect all control names if not yet done + If UBound(_ControlNames) < 0 Then + _ControlNames = _Form.getElementNames() + ' Remove all subforms from the list + For i = 0 To UBound(_ControlNames) + ' Subforms have no ClassId property + If Not ScriptForge.SF_Session.HasUnoProperty(_Form.getByName(_ControlNames(i)), "ClassId") Then _ControlNames(i) = "" + Next i + _ControlNames = ScriptForge.SF_Array.TrimArray(_ControlNames) + ' Size the cache accordingly + If UBound(_ControlNames) >= 0 Then + ReDim _ControlCache(0 To UBound(_ControlNames)) + End If + End If + + ' Return the list of controls or a FormControl instance + If Len(ControlName) = 0 Then + Controls = _ControlNames + + Else + + If Not _Form.hasByName(ControlName) Then GoTo CatchNotFound + lIndexOfNames = ScriptForge.SF_Array.IndexOf(_ControlNames, ControlName, CaseSensitive := True) + ' Reuse cache when relevant + vControl = _ControlCache(lIndexOfNames) + + If IsEmpty(vControl) Then + ' Create the new form control class instance + Set oControl = New SF_FormControl + With oControl + ._Name = ControlName + Set .[Me] = oControl + Set .[_Parent] = [Me] + Set ._ParentForm = [Me] + ._IndexOfNames = lIndexOfNames + ._FormName = _Name + ' Get model and view of the current control + Set ._ControlModel = _Form.getByName(ControlName) + ._Initialize() + End With + Else + Set oControl = vControl + End If + + Set Controls = oControl + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING, _Form.getElementNames()) + GoTo Finally +End Function ' SFDocuments.SF_Form.Controls + +REM ----------------------------------------------------------------------------- +Public Function GetDatabase(Optional ByVal User As Variant _ + , Optional ByVal Password As Variant _ + ) As Object +''' Returns a Database instance (service = SFDatabases.Database) giving access +''' to the execution of SQL commands on the database defined and/or stored in +''' the actual Base document +''' Each main form has its own database connection, except within Base documents where +''' they all share the same connection +''' Args: +''' User, Password: the login parameters as strings. Defaults = "" +''' Returns: +''' A SFDatabases.Database instance or Nothing +''' Example: +''' Dim myDb As Object +''' Set myDb = oForm.GetDatabase() + +Dim FSO As Object ' Alias for SF_FileSystem +Dim sUser As String ' Alias for User +Dim sPassword As String ' Alias for Password +Const cstThisSub = "SFDocuments.Form.GetDatabase" +Const cstSubArgs = "[User=""""], [Password=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set GetDatabase = Nothing + +Check: + If IsMissing(User) Or IsEmpty(User) Then User = "" + If IsMissing(Password) Or IsEmpty(Password) Then Password = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive(True) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(User, "User", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Password, "Password", V_STRING) Then GoTo Finally + End If + +Try: + ' Adjust connection arguments + If Len(User) = 0 Then + If ScriptForge.SF_Session.HasUnoProperty(_Form, "User") Then sUser = _Form.User Else sUser = "" + Else + sUser = User + End If + If Len(sUser) + Len(Password) = 0 Then + If ScriptForge.SF_Session.HasUnoProperty(_Form, "Password") Then sPassword = _Form.Password Else sPassword = Password + End If + + ' Connect to database, avoiding multiple requests + If IsNull(_Database) Then ' 1st connection request from the current form instance + If _FormType = ISBASEFORM Then + ' Fetch the shared connection + Set _Database = [_Parent].GetDatabase(User, Password) + ElseIf _FormType = ISSUBFORM Then + Set _Database = [_Parent].GetDatabase() ' Recursive call, climb the tree + ElseIf Len(_Form.DataSourceName) = 0 Then ' There is no database linked with the form + ' Return Nothing + Else + ' Check if DataSourceName is a file or a registered name and create database instance accordingly + Set FSO = ScriptForge.SF_FileSystem + If FSO.FileExists(FSO._ConvertFromUrl(_Form.DataSourceName)) Then + Set _Database = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database" _ + , _Form.DataSourceName, , , sUser, sPassword) + Else + Set _Database = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database" _ + , , _Form.DataSourceName, , sUser, sPassword) + End If + If IsNull(_Database) Then GoTo CatchConnect + End If + Else + EndIf + +Finally: + Set GetDatabase = _Database + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchConnect: + ScriptForge.SF_Exception.RaiseFatal(DBCONNECTERROR, "User", User, "Password", Password, [_Super]._FileIdent()) + GoTo Finally +End Function ' SFDocuments.SF_Form.GetDatabase + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist +''' Examples: +''' oDlg.GetProperty("Caption") + +Const cstThisSub = "SFDocuments.Form.GetProperty" +Const cstSubArgs = "" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Form service as an array + + Methods = Array( _ + "Activate" _ + , "CloseForm" _ + , "Controls" _ + , "GetDatabase" _ + , "MoveFirst" _ + , "MoveLast" _ + , "MoveNew" _ + , "MoveNext" _ + , "MovePrevious" _ + , "Requery" _ + , "SubForms" _ + ) + +End Function ' SFDocuments.SF_Form.Methods + +REM ----------------------------------------------------------------------------- +Public Function MoveFirst() As Boolean +''' The cursor is (re)positioned on the first row +''' Args: +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveFirst() + +Dim bMoveFirst As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.MoveFirst" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveFirst = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + bMoveFirst = .first() + End With + +Finally: + MoveFirst = bMoveFirst + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveFirst + +REM ----------------------------------------------------------------------------- +Public Function MoveLast() As Boolean +''' The cursor is (re)positioned on the last row +''' Args: +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveLast() + +Dim bMoveLast As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.MoveLast" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveLast = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + bMoveLast = .last() + End With + +Finally: + MoveLast = bMoveLast + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveLast + +REM ----------------------------------------------------------------------------- +Public Function MoveNew() As Boolean +''' The cursor is (re)positioned in the new record area +''' Args: +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveNew() + +Dim bMoveNew As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.MoveNew" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveNew = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + .last() ' To simulate the behaviour in the UI + .moveToInsertRow() + End With + bMoveNew = True + +Finally: + MoveNew = bMoveNew + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveNew + +REM ----------------------------------------------------------------------------- +Public Function MoveNext(Optional ByVal Offset As Variant) As Boolean +''' The cursor is (re)positioned on the next row +''' Args: +''' Offset: The number of records to go forward (default = 1) +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MoveNext() + +Dim bMoveNext As Boolean ' Return value +Dim lOffset As Long ' Alias of Offset +Const cstThisSub = "SFDocuments.Form.MoveNext" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMoveNext = False + +Check: + If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Finally + End If +Try: + lOffset = CLng(Offset) ' To be sure to have the right argument type + With _Form + If lOffset = 1 Then bMoveNext = .next() Else bMoveNext = .relative(lOffset) + End With + +Finally: + MoveNext = bMoveNext + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MoveNext + +REM ----------------------------------------------------------------------------- +Public Function MovePrevious(Optional ByVal Offset As Variant) As Boolean +''' The cursor is (re)positioned on the previous row +''' Args: +''' Offset: The number of records to go backward (default = 1) +''' Returns: +''' True if cursor move is successful +''' Example: +''' myForm.MovePrevious() + +Dim bMovePrevious As Boolean ' Return value +Dim lOffset As Long ' Alias of Offset +Const cstThisSub = "SFDocuments.Form.MovePrevious" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bMovePrevious = False + +Check: + If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1 + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Finally + End If +Try: + lOffset = CLng(Offset) ' To be sure to have the right argument type + With _Form + If lOffset = 1 Then bMovePrevious = .previous() Else bMovePrevious = .relative(-lOffset) + End With + +Finally: + MovePrevious = bMovePrevious + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.MovePrevious + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Form class as an array + + Properties = Array( _ + "AllowDeletes" _ + , "AllowInserts" _ + , "AllowUpdates" _ + , "BaseForm" _ + , "Bookmark" _ + , "CurrentRecord" _ + , "Filter" _ + , "LinkChildFields" _ + , "LinkParentFields" _ + , "Name" _ + , "OnApproveCursorMove" _ + , "OnApproveParameter" _ + , "OnApproveReset" _ + , "OnApproveRowChange" _ + , "OnApproveSubmit" _ + , "OnConfirmDelete" _ + , "OnCursorMoved" _ + , "OnErrorOccurred" _ + , "OnLoaded" _ + , "OnReloaded" _ + , "OnReloading" _ + , "OnResetted" _ + , "OnRowChanged" _ + , "OnUnloaded" _ + , "OnUnloading" _ + , "OrderBy" _ + , "Parent" _ + , "RecordSource" _ + , "XForm" _ + ) + +End Function ' SFDocuments.SF_Form.Properties + +REM ----------------------------------------------------------------------------- +Public Function Requery() As Boolean +''' Reload from the database the actual data into the form +''' The cursor is (re)positioned on the first row +''' Args: +''' Returns: +''' True if requery is successful +''' Example: +''' myForm.Requery() + +Dim bRequery As Boolean ' Return value +Const cstThisSub = "SFDocuments.Form.Requery" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bRequery = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + End If +Try: + With _Form + If .isLoaded() Then .reload() Else .load() + End With + bRequery = True + +Finally: + Requery = bRequery + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.Requery + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Form.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function Subforms(Optional ByVal Subform As Variant) As Variant +''' Return either +''' - the list of the subforms contained in the actual form or subform instance +''' - a SFDocuments.Form object based on its name or its index in the alphabetic list of subforms +''' Args: +''' Subform: a subform stored in the parent form given by its name or its index +''' When absent, the list of available subforms is returned +''' To get the first (unique ?) subform stored in the parent form, set Subform = 0 +''' Exceptions: +''' SUBFORMNOTFOUNDERROR Subform not found +''' Returns: +''' A zero-based array of strings if Subform is absent +''' An instance of the SF_Form class if Subform exists +''' Example: +''' Dim myForm As Object, myList As Variant, mySubform As Object +''' myList = myForm.Subforms() +''' Set mySubform = myForm.Subforms("mySubform") + +Dim oSubform As Object ' The new Form class instance +Dim oXSubform As Object ' com.sun.star.form.XForm +Dim vSubformNames As Variant ' Array of subform names +Dim i As Long +Const cstDrawPage = 0 ' Only 1 drawpage in a Writer document + +Const cstThisSub = "SFDocuments.Form.Subforms" +Const cstSubArgs = "[Subform=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Subform) Or IsEmpty(Subform) Then Subform = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Subform, "Subform", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + +Try: + ' Collect all control names and retain only the subforms + vSubformNames = _Form.getElementNames() + For i = 0 To UBound(vSubformNames) + Set oSubform = _Form.getByName(vSubformNames(i)) + ' Subforms are the only control types having no ClassId property + If ScriptForge.SF_Session.HasUnoProperty(oSubform, "ClassId") Then vSubformNames(i) = "" + Next i + vSubformNames = ScriptForge.SF_Array.TrimArray(vSubformNames) + + If Len(Subform) = 0 Then ' Return the list of valid subform names + Subforms = vSubformNames + Else + If VarType(Subform) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Array.Contains(vSubformNames, Subform, CaseSensitive := True) Then GoTo CatchNotFound + Set oXSubform = _Form.getByName(Subform) + Else ' Find the form by index + If Subform < 0 Or Subform > UBound(vSubformNames) Then GoTo CatchNotFound + Set oXSubform = _Form.getByName(vSubformNames(Subform)) + End If + ' Create the new Form class instance + Set oSubform = SF_Register._NewForm(oXSubform) + With oSubform + Set .[_Parent] = [Me] + ._FormType = ISSUBFORM + Set ._Component = _Component + Set ._FormDocument = _FormDocument + ._SheetName = _SheetName + ._FormDocumentName = _FormDocumentName + Set ._Database = _Database + ._Initialize() + End With + Set Subforms = oSubform + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(SUBFORMNOTFOUNDERROR, Subform, _Name) + GoTo Finally +End Function ' SFDocuments.SF_Form.Subforms + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDocuments.SF_Form._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnApproveCursorMove") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveParameter") + _GetListener = "XDatabaseParameterListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveRowChange") + _GetListener = "XRowSetApproveListener" + Case UCase("OnApproveSubmit") + _GetListener = "XSubmitListener" + Case UCase("OnConfirmDelete") + _GetListener = "XConfirmDeleteListener" + Case UCase("OnCursorMoved"), UCase("OnRowChanged") + _GetListener = "XRowSetListener" + Case UCase("OnErrorOccurred") + _GetListener = "XSQLErrorListener" + Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") + _GetListener = "XLoadListener" + End Select + +End Function ' SFDocuments.SF_Form._GetListener + +REM ----------------------------------------------------------------------------- +Private Sub _GetParents() +''' When the current instance is created top-down, the parents are completely defined +''' and nothing should be done in this method +''' When the a class instance is created in a (form/control) event, it is the opposite +''' The current method rebuilds the missing members in the instance from the bottom +''' Members potentially to collect are: +''' - _FormType +''' - [_Parent], the immediate parent: a form or a document instance +''' + Only when the _FormType is a main form +''' - _SheetName (Calc only) +''' - _FormDocumentName (Base only) +''' - _FormDocument, the topmost form collection +''' - _Component, the containing document +''' They must be identified only starting from the _Form UNO object +''' +''' The method is called from the _Initialize() method at instance creation + +Dim oParent As Object ' Successive bottom-up parents +Dim sType As String ' UNO object type +Dim sPersistentName As String ' The Obj... name of a Base form +Dim iLevel As Integer ' When = 1 => first parent +Dim oSession As Object : Set oSession = ScriptForge.SF_Session + + On Local Error GoTo Finally ' Being probably called from events, this method should avoid failures + ' When the form type is known, the upper part of the branch is not scanned + If _FormType <> ISUNDEFINED Then GoTo Finally + +Try: + ' The whole branch is scanned bottom-up + If oSession.HasUnoProperty(_Form, "Parent") Then Set oParent = _Form.Parent Else Set oParent = Nothing + _FormType = ISUNDEFINED + iLevel = 1 + + Do While Not IsNull(oParent) + sType = SF_Session.UnoObjectType(oParent) + Select Case sType + ' Collect at each level the needed info + Case "com.sun.star.comp.forms.ODatabaseForm" ' The parent _Form of a subform + If iLevel = 1 Then + _FormType = ISSUBFORM + Set [_Parent] = SF_Register._NewForm(oParent) + ' Everything is in the parent, copy items and stop scan + [_Parent]._Initialize() ' Current method is called recursively here + With [_Parent] + _SheetName = ._SheetName + _FormDocumentName = ._FormDocumentName + Set _FormDocument = ._FormDocument + Set _Component = ._Component + End With + Exit Sub + End If + Case "com.sun.star.form.OFormsCollection" ' The collection of forms inside a drawpage + Case "SwXTextDocument" ' The parent document: a Writer document or a Base form document + If oParent.Identifier = "com.sun.star.sdb.FormDesign" Then + sPersistentName = ScriptForge._GetPropertyValue(oParent.Args, "HierarchicalDocumentName") + ElseIf oParent.Identifier = "com.sun.star.text.TextDocument" Then + _FormType = ISDOCFORM + Set [_Parent] = ScriptForge.SF_Services.CreateScriptService("SFDocuments.Document", oParent) + Set _Component = [_Parent]._Component + End If + Case "ScModelObj" ' The parent document: a Calc document + _FormType = ISCALCFORM + Set [_Parent] = ScriptForge.SF_Services.CreateScriptService("SFDocuments.Document", oParent) + Set _Component = oParent + ' The triggered form event is presumed to be located in the (drawpage of the) active sheet + _SheetName = [_Parent].XSpreadsheet("~") + Case "com.sun.star.comp.dba.ODatabaseDocument" ' The Base document + _FormType = ISBASEFORM + Set [_Parent] = ScriptForge.SF_Services.CreateScriptService("SFDocuments.Document", oParent) + Set _Component = oParent + If IsNull([_Parent]._FormDocuments) Then Set [_Parent]._FormDocuments = _Component.getFormDocuments() + Set _FormDocument = [_Parent]._FindByPersistentName([_Parent]._FormDocuments, sPersistentName) + _FormDocumentName = _FormDocument.HierarchicalName + Case Else + End Select + If oSession.HasUnoProperty(oParent, "Parent") Then Set oParent = oParent.Parent Else Set oParent = Nothing + iLevel = iLevel + 1 + Loop + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_Form._GetParents + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Achieve the creation of a SF_Form instance +''' - complete the missing private members +''' - store the new instance in the cache + + _GetParents() + _CacheIndex = SF_Register._AddFormToCache(_Form, [Me]) + +End Sub ' SFDocuments.SF_Form._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbError As Boolean) As Boolean +''' Return True if the Form is still open +''' If dead the actual instance is disposed +''' and the execution is cancelled when pbError = True (default) +''' Args: +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value +Dim sName As String ' Alias of _Name +Dim sId As String ' Alias of FileIdent + +Check: + On Local Error GoTo Catch ' Anticipate DisposedException errors or alike + If IsMissing(pbError) Then pbError = True + +Try: + ' At main form termination, all database connections are lost + bAlive = Not IsNull(_Form) + If Not bAlive Then GoTo Catch + +Finally: + _IsStillAlive = bAlive + Exit Function +Catch: + bAlive = False + On Error GoTo 0 + ' Keep error message elements before disposing the instance + sName = _SheetName & _FormDocumentName ' At least one of them is a zero-length string + sName = Iif(Len(sName) > 0, "[" & sName & "].", "") & _Name + If Not IsNull(_Component) Then sId = _Component.Location Else sId = "" + ' Dispose the actual forms instance + Dispose() + ' Display error message + If pbError Then ScriptForge.SF_Exception.RaiseFatal(FORMDEADERROR, sName, sId) + GoTo Finally +End Function ' SFDocuments.SF_Form._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Static oSession As Object ' Alias of SF_Session +Dim vBookmark As Variant ' Form bookmark +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDocuments.Form.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + _PropertyGet = Empty + If Not _IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("AllowDeletes") + If Not IsNull(_Form) Then _PropertyGet = _Form.AllowDeletes + Case UCase("AllowInserts") + If Not IsNull(_Form) Then _PropertyGet = _Form.AllowInserts + Case UCase("AllowUpdates") + If Not IsNull(_Form) Then _PropertyGet = _Form.AllowUpdates + Case UCase("BaseForm") + _PropertyGet = _FormDocumentName + Case UCase("Bookmark") + If IsNull(_Form) Then + _PropertyGet = 0 + Else + On Local Error Resume Next ' Disable error handler because bookmarking does not always react well in events ... + If _Form.IsBookmarkable Then vBookmark = _Form.getBookmark() Else vBookmark = Nothing + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error Goto Catch Else On Local Error Goto 0 + If IsNull(vBookmark) Then Goto Catch + _PropertyGet = vBookmark + End If + Case UCase("CurrentRecord") + If IsNull(_Form) Then _PropertyGet = 0 Else _PropertyGet = _Form.Row + Case UCase("Filter") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = _Form.Filter + Case UCase("LinkChildFields") + If IsNull(_Form) Or _FormType <> ISSUBFORM Then _PropertyGet = Array() Else _PropertyGet = _Form.DetailFields + Case UCase("LinkParentFields") + If IsNull(_Form) Or _FormType <> ISSUBFORM Then _PropertyGet = Array() Else _PropertyGet = _Form.MasterFields + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = SF_Register._GetEventScriptCode(_Form, psProperty, _Name) + Case UCase("OrderBy") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = _Form.Order + Case UCase("Parent") + _PropertyGet = [_Parent] + Case UCase("RecordSource") + If IsNull(_Form) Then _PropertyGet = "" Else _PropertyGet = _Form.Command + Case UCase("XForm") + Set _PropertyGet = _Form + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Dim oDatabase As Object ' Database class instance +Dim lCommandType As Long ' Record source type: 0 = Table, 1 = Query, 2 = SELECT +Dim sCommand As String ' Record source +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Form.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("AllowDeletes") + If Not ScriptForge.SF_Utils._Validate(pvValue, "AllowDeletes", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not IsNull(_Form) Then + _Form.AllowDeletes = pvValue + _Form.reload() + End If + Case UCase("AllowInserts") + If Not ScriptForge.SF_Utils._Validate(pvValue, "AllowInserts", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not IsNull(_Form) Then + _Form.AllowInserts = pvValue + _Form.reload() + End If + Case UCase("AllowUpdates") + If Not ScriptForge.SF_Utils._Validate(pvValue, "AllowUpdates", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not IsNull(_Form) Then + _Form.AllowUpdates = pvValue + _Form.reload() + End If + Case UCase("Bookmark") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Bookmark", Array(ScriptForge.V_NUMERIC, ScriptForge.V_OBJECT)) Then GoTo Finally + If Not IsNull(pvValue) And Not IsNull(_Form) Then bSet = _Form.moveToBookmark(pvValue) + Case UCase("CurrentRecord") + If Not ScriptForge.SF_Utils._Validate(pvValue, "CurrentRecord", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not IsNull(_Form) Then bSet = _Form.absolute(pvValue) + Case UCase("Filter") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Filter", V_STRING) Then GoTo Finally + If Not IsNull(_Form) Then + With _Form + If Len(pvValue) > 0 Then + Set oDatabase = GetDatabase() + If Not IsNull(oDatabase) Then .Filter = oDatabase._ReplaceSquareBrackets(pvValue) Else .Filter = pvValue + Else + .Filter = "" + End If + .ApplyFilter = True + .reload() + End With + End If + Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ + , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ + , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ + , UCase("OnUnloaded"), UCase("OnUnloading") + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then Goto Finally + If Not IsNull(_Form) Then + bSet = SF_Register._RegisterEventScript(_Form _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + , _Name _ + ) + End If + Case UCase("OrderBy") + If Not ScriptForge.SF_Utils._Validate(pvValue, "OrderBy", V_STRING) Then GoTo Finally + If Not IsNull(_Form) Then + With _Form + If Len(pvValue) > 0 Then + Set oDatabase = GetDatabase() + If Not IsNull(oDatabase) Then .Order = oDatabase._ReplaceSquareBrackets(pvValue) Else .Order = pvValue + Else + .Order = "" + End If + .reload() + End With + End If + Case UCase("RecordSource") + If Not ScriptForge.SF_Utils._Validate(pvValue, "RecordSource", V_STRING) Then GoTo Finally + If Not IsNull(_Form) And Len(pvValue) > 0 Then + Set oDatabase = GetDatabase() + If Not IsNull(oDatabase) Then + With oDatabase + If ScriptForge.SF_Array.Contains(.Tables, pvValue, CaseSensitive := True) Then + sCommand = pvValue + lCommandType = com.sun.star.sdb.CommandType.TABLE + ElseIf ScriptForge.SF_Array.Contains(.Queries, pvValue, CaseSensitive := True) Then + sCommand = pvValue + lCommandType = com.sun.star.sdb.CommandType.QUERY + ElseIf ScriptForge.SF_String.StartsWith(pvValue, "SELECT", CaseSensitive := False) Then + sCommand = .ReplaceSquareBrackets(pvValue) + lCommandType = com.sun.star.sdb.CommandType.COMMAND + End If + _Form.Command = sCommand + _Form.CommandType = lCommandType + End With + End If + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Form._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Form]: Name" + +Dim sParent As String ' To recognize the parent + + sParent = _SheetName & _FormDocumentName ' At least one of them is a zero-length string + _Repr = "[Form]: " & Iif(Len(sParent) > 0, sParent & "...", "") & _Name + +End Function ' SFDocuments.SF_Form._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_FORM + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_FormControl.xba b/wizards/source/sfdocuments/SF_FormControl.xba new file mode 100644 index 000000000..a48c22b6c --- /dev/null +++ b/wizards/source/sfdocuments/SF_FormControl.xba @@ -0,0 +1,1888 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_FormControl +''' ================ +''' Manage the controls belonging to a form or subform stored in a document +''' Each instance of the current class represents a single control within a form, a subform or a tablecontrol +''' A prerequisite is that all controls within the same form, subform or tablecontrol must have +''' a unique name. This is also true for the individual radio buttons belonging to the same group. +''' A common group name must identify such a single group. +''' +''' The focus is clearly set on getting and setting the values displayed by the controls of the form, +''' not on their formatting. The latter is easily accessible via the XControlModel and XControlView +''' UNO objects. +''' Essentially a single property "Value" maps many alternative UNO properties depending each on +''' the control type. +''' +''' Service invocations: +''' Dim myForm As Object, myControl As Object +''' Set myForm = ... (read the comments in the SF_Form module) +''' Set myControl = myForm.Controls("myTextBox") +''' myControl.Value = "Current time = " & Now() +''' +''' REM the control is the subject of an event +''' Sub OnEvent(ByRef poEvent As Object) +''' Dim myControl As Object +''' Set myControl = CreateScriptService("SFDocuments.FormEvent", poEvent) +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_formcontrol.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const FORMCONTROLTYPEERROR = "FORMCONTROLTYPEERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be FORMCONTROL +Private ServiceName As String + +' Control naming and context +Private _Name As String +Private _IndexOfNames As Long ' Index in ElementNames array. Used to access SF_Form._ControlCache +Private _FormName As String ' Parent form name +Private _ParentForm As Object ' Parent form or subform instance +Private _ParentIsTable As Boolean ' True when parent is a table control + +' Control UNO references +Private _ControlModel As Object ' com.sun.star.awt.XControlModel +Private _ControlView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl + +' Control attributes +Private _ImplementationName As String +Private _ControlType As String ' One of the CTLxxx constants +Private _ClassId As Integer ' Numerical type of control + +' Cache storage for table controls +Private _ControlNames As Variant ' Array of control names +Private _ControlCache As Variant ' Array of control objects sorted like ElementNames of XControlModel + +REM ============================================================ MODULE CONSTANTS + +' ClassId +Private Const CTLBUTTON = "Button" ' 2 +Private Const CTLCHECKBOX = "CheckBox" ' 5 +Private Const CTLCOMBOBOX = "ComboBox" ' 7 +Private Const CTLCURRENCYFIELD = "CurrencyField" ' 18 +Private Const CTLDATEFIELD = "DateField" ' 15 +Private Const CTLFILECONTROL = "FileControl" ' 12 +Private Const CTLFIXEDTEXT = "FixedText" ' 10 +Private Const CTLFORMATTEDFIELD = "FormattedField" ' Idem TextField +Private Const CTLGROUPBOX = "GroupBox" ' 8 +Private Const CTLHIDDENCONTROL = "HiddenControl" ' 13 +Private Const CTLIMAGEBUTTON = "ImageButton" ' 4 +Private Const CTLIMAGECONTROL = "ImageControl" ' 14 +Private Const CTLLISTBOX = "ListBox" ' 6 +Private Const CTLNAVIGATIONBAR = "NavigationBar" ' 22 +Private Const CTLNUMERICFIELD = "NumericField" ' 17 +Private Const CTLPATTERNFIELD = "PatternField" ' 19 +Private Const CTLRADIOBUTTON = "RadioButton" ' 3 +Private Const CTLSCROLLBAR = "ScrollBar" ' 20 +Private Const CTLSPINBUTTON = "SpinButton" ' 21 +Private Const CTLTABLECONTROL = "TableControl" ' 11 +Private Const CTLTEXTFIELD = "TextField" ' 9 +Private Const CTLTIMEFIELD = "TimeField" ' 16 + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "FORMCONTROL" + ServiceName = "SFDocuments.FormControl" + _Name = "" + _IndexOfNames = -1 + _FormName = "" + _ParentIsTable = False + Set _ParentForm = Nothing + Set _ControlModel = Nothing + Set _ControlView = Nothing + _ImplementationName = "" + _ControlType = "" + _ClassId = 0 + _ControlNames = Array() + _ControlCache = Array() +End Sub ' SFDocuments.SF_FormControl Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_FormControl Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Parent]) And _IndexOfNames >= 0 Then [_Parent]._ControlCache(_IndexOfNames) = Empty + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_FormControl Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Action() As Variant +''' The Action property specifies the action triggered when the button is clicked +''' Accepted values: none, submitForm, resetForm, refreshForm, moveToFirst, moveToLast, +''' moveToNext, moveToPrev, saveRecord, moveToNew, deleteRecord, undoRecord + Action = _PropertyGet("Action", "") +End Property ' SFDocuments.SF_FormControl.Action (get) + +REM ----------------------------------------------------------------------------- +Property Let Action(Optional ByVal pvAction As Variant) +''' Set the updatable property Action + _PropertySet("Action", pvAction) +End Property ' SFDocuments.SF_FormControl.Action (let) + +REM ----------------------------------------------------------------------------- +Property Get Caption() As Variant +''' The Caption property refers to the text associated with the control + Caption = _PropertyGet("Caption", "") +End Property ' SFDocuments.SF_FormControl.Caption (get) + +REM ----------------------------------------------------------------------------- +Property Let Caption(Optional ByVal pvCaption As Variant) +''' Set the updatable property Caption + _PropertySet("Caption", pvCaption) +End Property ' SFDocuments.SF_FormControl.Caption (let) + +REM ----------------------------------------------------------------------------- +Property Get ControlSource() As Variant +''' The ControlSource property specifies the rowset field mapped onto the actual control + ControlSource = _PropertyGet("ControlSource", "") +End Property ' SFDocuments.SF_FormControl.ControlSource (get) + +REM ----------------------------------------------------------------------------- +Property Get ControlType() As String +''' Return the type of the actual control: "CheckBox", "TextField", "DateField", ... + ControlType = _PropertyGet("ControlType") +End Property ' SFDocuments.SF_FormControl.ControlType + +REM ----------------------------------------------------------------------------- +Property Get Default() As Variant +''' The Default property specifies whether a command button is the default (OK) button. + Default = _PropertyGet("Default", False) +End Property ' SFDocuments.SF_FormControl.Default (get) + +REM ----------------------------------------------------------------------------- +Property Let Default(Optional ByVal pvDefault As Variant) +''' Set the updatable property Default + _PropertySet("Default", pvDefault) +End Property ' SFDocuments.SF_FormControl.Default (let) + +REM ----------------------------------------------------------------------------- +Property Get DefaultValue() As Variant +''' The DefaultValue property specifies how the control is initialized in a new record + DefaultValue = _PropertyGet("DefaultValue", Null) +End Property ' SFDocuments.SF_FormControl.DefaultValue (get) + +REM ----------------------------------------------------------------------------- +Property Let DefaultValue(Optional ByVal pvDefaultValue As Variant) +''' Set the updatable property DefaultValue + _PropertySet("DefaultValue", pvDefaultValue) +End Property ' SFDocuments.SF_FormControl.DefaultValue (let) + +REM ----------------------------------------------------------------------------- +Property Get Enabled() As Variant +''' The Enabled property specifies if the control is accessible with the cursor. + Enabled = _PropertyGet("Enabled", False) +End Property ' SFDocuments.SF_FormControl.Enabled (get) + +REM ----------------------------------------------------------------------------- +Property Let Enabled(Optional ByVal pvEnabled As Variant) +''' Set the updatable property Enabled + _PropertySet("Enabled", pvEnabled) +End Property ' SFDocuments.SF_FormControl.Enabled (let) + +REM ----------------------------------------------------------------------------- +Property Get Format() As Variant +''' The Format property specifies the format in which to display dates and times. + Format = _PropertyGet("Format", "") +End Property ' SFDocuments.SF_FormControl.Format (get) + +REM ----------------------------------------------------------------------------- +Property Let Format(Optional ByVal pvFormat As Variant) +''' Set the updatable property Format +''' NB: Format is read-only for formatted field controls + _PropertySet("Format", pvFormat) +End Property ' SFDocuments.SF_FormControl.Format (let) + +REM ----------------------------------------------------------------------------- +Property Get ListCount() As Long +''' The ListCount property specifies the number of rows in a list box or a combo box + ListCount = _PropertyGet("ListCount", 0) +End Property ' SFDocuments.SF_FormControl.ListCount (get) + +REM ----------------------------------------------------------------------------- +Property Get ListIndex() As Variant +''' The ListIndex property specifies which item is selected in a list box or combo box. +''' In case of multiple selection, the index of the first one is returned or only one is set + ListIndex = _PropertyGet("ListIndex", -1) +End Property ' SFDocuments.SF_FormControl.ListIndex (get) + +REM ----------------------------------------------------------------------------- +Property Let ListIndex(Optional ByVal pvListIndex As Variant) +''' Set the updatable property ListIndex + _PropertySet("ListIndex", pvListIndex) +End Property ' SFDocuments.SF_FormControl.ListIndex (let) + +REM ----------------------------------------------------------------------------- +Property Get ListSource() As Variant +''' The ListSource property specifies the data contained in a combobox or a listbox +''' as a zero-based array of string values + ListSource = _PropertyGet("ListSource", "") +End Property ' SFDocuments.SF_FormControl.ListSource (get) + +REM ----------------------------------------------------------------------------- +Property Let ListSource(Optional ByVal pvListSource As Variant) +''' Set the updatable property ListSource + _PropertySet("ListSource", pvListSource) +End Property ' SFDocuments.SF_FormControl.ListSource (let) + +REM ----------------------------------------------------------------------------- +Property Get ListSourceType() As Variant +''' The ListSourceType property specifies the kind of data source used to fill the list data of a listbox or a combobox + ListSourceType = _PropertyGet("ListSourceType", "") +End Property ' SFDocuments.SF_FormControl.ListSourceType (get) + +REM ----------------------------------------------------------------------------- +Property Let ListSourceType(Optional ByVal pvListSourceType As Variant) +''' Set the updatable property ListSourceType + _PropertySet("ListSourceType", pvListSourceType) +End Property ' SFDocuments.SF_FormControl.ListSourceType (let) + +REM ----------------------------------------------------------------------------- +Property Get Locked() As Variant +''' The Locked property specifies if a control is read-only + Locked = _PropertyGet("Locked", False) +End Property ' SFDocuments.SF_FormControl.Locked (get) + +REM ----------------------------------------------------------------------------- +Property Let Locked(Optional ByVal pvLocked As Variant) +''' Set the updatable property Locked + _PropertySet("Locked", pvLocked) +End Property ' SFDocuments.SF_FormControl.Locked (let) + +REM ----------------------------------------------------------------------------- +Property Get MultiSelect() As Variant +''' The MultiSelect property specifies whether a user can make multiple selections in a listbox + MultiSelect = _PropertyGet("MultiSelect", False) +End Property ' SFDocuments.SF_FormControl.MultiSelect (get) + +REM ----------------------------------------------------------------------------- +Property Let MultiSelect(Optional ByVal pvMultiSelect As Variant) +''' Set the updatable property MultiSelect + _PropertySet("MultiSelect", pvMultiSelect) +End Property ' SFDocuments.SF_FormControl.MultiSelect (let) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual control + Name = _PropertyGet("Name") +End Property ' SFDocuments.SF_FormControl.Name + +REM ----------------------------------------------------------------------------- +Property Get OnActionPerformed() As Variant +''' Get the script associated with the OnActionPerformed event + OnActionPerformed = _PropertyGet("OnActionPerformed", "") +End Property ' SFDocuments.SF_FormControl.OnActionPerformed (get) + +REM ----------------------------------------------------------------------------- +Property Let OnActionPerformed(Optional ByVal pvOnActionPerformed As Variant) +''' Set the updatable property OnActionPerformed + _PropertySet("OnActionPerformed", pvOnActionPerformed) +End Property ' SFDocuments.SF_FormControl.OnActionPerformed (let) + +REM ----------------------------------------------------------------------------- +Property Get OnAdjustmentValueChanged() As Variant +''' Get the script associated with the OnAdjustmentValueChanged event + OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged", "") +End Property ' SFDocuments.SF_FormControl.OnAdjustmentValueChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnAdjustmentValueChanged(Optional ByVal pvOnAdjustmentValueChanged As Variant) +''' Set the updatable property OnAdjustmentValueChanged + _PropertySet("OnAdjustmentValueChanged", pvOnAdjustmentValueChanged) +End Property ' SFDocuments.SF_FormControl.OnAdjustmentValueChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveAction() As Variant +''' Get the script associated with the OnApproveAction event + OnApproveAction = _PropertyGet("OnApproveAction", "") +End Property ' SFDocuments.SF_FormControl.OnApproveAction (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveAction(Optional ByVal pvOnApproveAction As Variant) +''' Set the updatable property OnApproveAction + _PropertySet("OnApproveAction", pvOnApproveAction) +End Property ' SFDocuments.SF_FormControl.OnApproveAction (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveReset() As Variant +''' Get the script associated with the OnApproveReset event + OnApproveReset = _PropertyGet("OnApproveReset", "") +End Property ' SFDocuments.SF_FormControl.OnApproveReset (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveReset(Optional ByVal pvOnApproveReset As Variant) +''' Set the updatable property OnApproveReset + _PropertySet("OnApproveReset", pvOnApproveReset) +End Property ' SFDocuments.SF_FormControl.OnApproveReset (let) + +REM ----------------------------------------------------------------------------- +Property Get OnApproveUpdate() As Variant +''' Get the script associated with the OnApproveUpdate event + OnApproveUpdate = _PropertyGet("OnApproveUpdate", "") +End Property ' SFDocuments.SF_FormControl.OnApproveUpdate (get) + +REM ----------------------------------------------------------------------------- +Property Let OnApproveUpdate(Optional ByVal pvOnApproveUpdate As Variant) +''' Set the updatable property OnApproveUpdate + _PropertySet("OnApproveUpdate", pvOnApproveUpdate) +End Property ' SFDocuments.SF_FormControl.OnApproveUpdate (let) + +REM ----------------------------------------------------------------------------- +Property Get OnChanged() As Variant +''' Get the script associated with the OnChanged event + OnChanged = _PropertyGet("OnChanged", "") +End Property ' SFDocuments.SF_FormControl.OnChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnChanged(Optional ByVal pvOnChanged As Variant) +''' Set the updatable property OnChanged + _PropertySet("OnChanged", pvOnChanged) +End Property ' SFDocuments.SF_FormControl.OnChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnErrorOccurred() As Variant +''' Get the script associated with the OnErrorOccurred event + OnErrorOccurred = _PropertyGet("OnErrorOccurred", "") +End Property ' SFDocuments.SF_FormControl.OnErrorOccurred (get) + +REM ----------------------------------------------------------------------------- +Property Let OnErrorOccurred(Optional ByVal pvOnErrorOccurred As Variant) +''' Set the updatable property OnErrorOccurred + _PropertySet("OnErrorOccurred", pvOnErrorOccurred) +End Property ' SFDocuments.SF_FormControl.OnErrorOccurred (let) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant +''' Get the script associated with the OnFocusGained event + OnFocusGained = _PropertyGet("OnFocusGained", "") +End Property ' SFDocuments.SF_FormControl.OnFocusGained (get) + +REM ----------------------------------------------------------------------------- +Property Let OnFocusGained(Optional ByVal pvOnFocusGained As Variant) +''' Set the updatable property OnFocusGained + _PropertySet("OnFocusGained", pvOnFocusGained) +End Property ' SFDocuments.SF_FormControl.OnFocusGained (let) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant +''' Get the script associated with the OnFocusLost event + OnFocusLost = _PropertyGet("OnFocusLost", "") +End Property ' SFDocuments.SF_FormControl.OnFocusLost (get) + +REM ----------------------------------------------------------------------------- +Property Let OnFocusLost(Optional ByVal pvOnFocusLost As Variant) +''' Set the updatable property OnFocusLost + _PropertySet("OnFocusLost", pvOnFocusLost) +End Property ' SFDocuments.SF_FormControl.OnFocusLost (let) + +REM ----------------------------------------------------------------------------- +Property Get OnItemStateChanged() As Variant +''' Get the script associated with the OnItemStateChanged event + OnItemStateChanged = _PropertyGet("OnItemStateChanged", "") +End Property ' SFDocuments.SF_FormControl.OnItemStateChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnItemStateChanged(Optional ByVal pvOnItemStateChanged As Variant) +''' Set the updatable property OnItemStateChanged + _PropertySet("OnItemStateChanged", pvOnItemStateChanged) +End Property ' SFDocuments.SF_FormControl.OnItemStateChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant +''' Get the script associated with the OnKeyPressed event + OnKeyPressed = _PropertyGet("OnKeyPressed", "") +End Property ' SFDocuments.SF_FormControl.OnKeyPressed (get) + +REM ----------------------------------------------------------------------------- +Property Let OnKeyPressed(Optional ByVal pvOnKeyPressed As Variant) +''' Set the updatable property OnKeyPressed + _PropertySet("OnKeyPressed", pvOnKeyPressed) +End Property ' SFDocuments.SF_FormControl.OnKeyPressed (let) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant +''' Get the script associated with the OnKeyReleased event + OnKeyReleased = _PropertyGet("OnKeyReleased", "") +End Property ' SFDocuments.SF_FormControl.OnKeyReleased (get) + +REM ----------------------------------------------------------------------------- +Property Let OnKeyReleased(Optional ByVal pvOnKeyReleased As Variant) +''' Set the updatable property OnKeyReleased + _PropertySet("OnKeyReleased", pvOnKeyReleased) +End Property ' SFDocuments.SF_FormControl.OnKeyReleased (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant +''' Get the script associated with the OnMouseDragged event + OnMouseDragged = _PropertyGet("OnMouseDragged", "") +End Property ' SFDocuments.SF_FormControl.OnMouseDragged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseDragged(Optional ByVal pvOnMouseDragged As Variant) +''' Set the updatable property OnMouseDragged + _PropertySet("OnMouseDragged", pvOnMouseDragged) +End Property ' SFDocuments.SF_FormControl.OnMouseDragged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant +''' Get the script associated with the OnMouseEntered event + OnMouseEntered = _PropertyGet("OnMouseEntered", "") +End Property ' SFDocuments.SF_FormControl.OnMouseEntered (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseEntered(Optional ByVal pvOnMouseEntered As Variant) +''' Set the updatable property OnMouseEntered + _PropertySet("OnMouseEntered", pvOnMouseEntered) +End Property ' SFDocuments.SF_FormControl.OnMouseEntered (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant +''' Get the script associated with the OnMouseExited event + OnMouseExited = _PropertyGet("OnMouseExited", "") +End Property ' SFDocuments.SF_FormControl.OnMouseExited (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseExited(Optional ByVal pvOnMouseExited As Variant) +''' Set the updatable property OnMouseExited + _PropertySet("OnMouseExited", pvOnMouseExited) +End Property ' SFDocuments.SF_FormControl.OnMouseExited (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant +''' Get the script associated with the OnMouseMoved event + OnMouseMoved = _PropertyGet("OnMouseMoved", "") +End Property ' SFDocuments.SF_FormControl.OnMouseMoved (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseMoved(Optional ByVal pvOnMouseMoved As Variant) +''' Set the updatable property OnMouseMoved + _PropertySet("OnMouseMoved", pvOnMouseMoved) +End Property ' SFDocuments.SF_FormControl.OnMouseMoved (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant +''' Get the script associated with the OnMousePressed event + OnMousePressed = _PropertyGet("OnMousePressed", "") +End Property ' SFDocuments.SF_FormControl.OnMousePressed (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMousePressed(Optional ByVal pvOnMousePressed As Variant) +''' Set the updatable property OnMousePressed + _PropertySet("OnMousePressed", pvOnMousePressed) +End Property ' SFDocuments.SF_FormControl.OnMousePressed (let) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant +''' Get the script associated with the OnMouseReleased event + OnMouseReleased = _PropertyGet("OnMouseReleased", "") +End Property ' SFDocuments.SF_FormControl.OnMouseReleased (get) + +REM ----------------------------------------------------------------------------- +Property Let OnMouseReleased(Optional ByVal pvOnMouseReleased As Variant) +''' Set the updatable property OnMouseReleased + _PropertySet("OnMouseReleased", pvOnMouseReleased) +End Property ' SFDocuments.SF_FormControl.OnMouseReleased (let) + +REM ----------------------------------------------------------------------------- +Property Get OnResetted() As Variant +''' Get the script associated with the OnResetted event + OnResetted = _PropertyGet("OnResetted", "") +End Property ' SFDocuments.SF_FormControl.OnResetted (get) + +REM ----------------------------------------------------------------------------- +Property Let OnResetted(Optional ByVal pvOnResetted As Variant) +''' Set the updatable property OnResetted + _PropertySet("OnResetted", pvOnResetted) +End Property ' SFDocuments.SF_FormControl.OnResetted (let) + +REM ----------------------------------------------------------------------------- +Property Get OnTextChanged() As Variant +''' Get the script associated with the OnTextChanged event + OnTextChanged = _PropertyGet("OnTextChanged", "") +End Property ' SFDocuments.SF_FormControl.OnTextChanged (get) + +REM ----------------------------------------------------------------------------- +Property Let OnTextChanged(Optional ByVal pvOnTextChanged As Variant) +''' Set the updatable property OnTextChanged + _PropertySet("OnTextChanged", pvOnTextChanged) +End Property ' SFDocuments.SF_FormControl.OnTextChanged (let) + +REM ----------------------------------------------------------------------------- +Property Get OnUpdated() As Variant +''' Get the script associated with the OnUpdated event + OnUpdated = _PropertyGet("OnUpdated", "") +End Property ' SFDocuments.SF_FormControl.OnUpdated (get) + +REM ----------------------------------------------------------------------------- +Property Let OnUpdated(Optional ByVal pvOnUpdated As Variant) +''' Set the updatable property OnUpdated + _PropertySet("OnUpdated", pvOnUpdated) +End Property ' SFDocuments.SF_FormControl.OnUpdated (let) + +REM ----------------------------------------------------------------------------- +Property Get Parent() As Object +''' Return the Parent form or [table]control object of the actual control + Parent = _PropertyGet("Parent", Nothing) +End Property ' SFDocuments.SF_FormControl.Parent + +REM ----------------------------------------------------------------------------- +Property Get Picture() As Variant +''' The Picture property specifies a bitmap or other type of graphic to be displayed on the specified control + Picture = _PropertyGet("Picture", "") +End Property ' SFDocuments.SF_FormControl.Picture (get) + +REM ----------------------------------------------------------------------------- +Property Let Picture(Optional ByVal pvPicture As Variant) +''' Set the updatable property Picture + _PropertySet("Picture", pvPicture) +End Property ' SFDocuments.SF_FormControl.Picture (let) + +REM ----------------------------------------------------------------------------- +Property Get Required() As Variant +''' A control is said Required when it must not contain a null value + Required = _PropertyGet("Required", False) +End Property ' SFDocuments.SF_FormControl.Required (get) + +REM ----------------------------------------------------------------------------- +Property Let Required(Optional ByVal pvRequired As Variant) +''' Set the updatable property Required + _PropertySet("Required", pvRequired) +End Property ' SFDocuments.SF_FormControl.Required (let) + +REM ----------------------------------------------------------------------------- +Property Get Text() As Variant +''' The Text property specifies the actual content of the control like it is displayed on the screen + Text = _PropertyGet("Text", "") +End Property ' SFDocuments.SF_FormControl.Text (get) + +REM ----------------------------------------------------------------------------- +Property Get TipText() As Variant +''' The TipText property specifies the text that appears in a screentip when you hold the mouse pointer over a control + TipText = _PropertyGet("TipText", "") +End Property ' SFDocuments.SF_FormControl.TipText (get) + +REM ----------------------------------------------------------------------------- +Property Let TipText(Optional ByVal pvTipText As Variant) +''' Set the updatable property TipText + _PropertySet("TipText", pvTipText) +End Property ' SFDocuments.SF_FormControl.TipText (let) + +REM ----------------------------------------------------------------------------- +Property Get TripleState() As Variant +''' The TripleState property specifies how a check box will display Null values +''' When True, the control will cycle through states for Yes, No, and Null values. The control appears dimmed (grayed) when its Value property is set to Null. +''' When False, the control will cycle through states for Yes and No values. Null values display as if they were No values. + TripleState = _PropertyGet("TripleState", False) +End Property ' SFDocuments.SF_FormControl.TripleState (get) + +REM ----------------------------------------------------------------------------- +Property Let TripleState(Optional ByVal pvTripleState As Variant) +''' Set the updatable property TripleState + _PropertySet("TripleState", pvTripleState) +End Property ' SFDocuments.SF_FormControl.TripleState (let) + +REM ----------------------------------------------------------------------------- +Property Get Value() As Variant +''' The Value property specifies the data contained in the control + Value = _PropertyGet("Value", Empty) +End Property ' SFDocuments.SF_FormControl.Value (get) + +REM ----------------------------------------------------------------------------- +Property Let Value(Optional ByVal pvValue As Variant) +''' Set the updatable property Value + _PropertySet("Value", pvValue) +End Property ' SFDocuments.SF_FormControl.Value (let) + +REM ----------------------------------------------------------------------------- +Property Get Visible() As Variant +''' The Visible property specifies if the control is accessible with the cursor. + Visible = _PropertyGet("Visible", True) +End Property ' SFDocuments.SF_FormControl.Visible (get) + +REM ----------------------------------------------------------------------------- +Property Let Visible(Optional ByVal pvVisible As Variant) +''' Set the updatable property Visible + _PropertySet("Visible", pvVisible) +End Property ' SFDocuments.SF_FormControl.Visible (let) + +REM ----------------------------------------------------------------------------- +Property Get XControlModel() As Object +''' The XControlModel property returns the model UNO object of the control + XControlModel = _PropertyGet("XControlModel", Nothing) +End Property ' SFDocuments.SF_FormControl.XControlModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XControlView() As Object +''' The XControlView property returns the view UNO object of the control + XControlView = _PropertyGet("XControlView", Nothing) +End Property ' SFDocuments.SF_FormControl.XControlView (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Controls(Optional ByVal ControlName As Variant) As Variant +''' Return either +''' - the list of the controls contained in the actual table control +''' - a Form Control object based on its name +''' Args: +''' ControlName: a valid control name as a case-sensitive string. If absent the list is returned +''' Returns: +''' A zero-base array of strings if ControlName is absent +''' An instance of the SF_FormControl class if ControlName exists +''' Exceptions: +''' ControlName is invalid +''' Example: +''' Dim myGrid As Object, myList As Variant, myControl As Object +''' Set myGrid = myForm.Controls("myTableControl") +''' myList = myGrid.Controls() +''' Set myControl = myGrid.Controls("myCheckBox") + +Dim oControl As Object ' The new control class instance +Dim lIndexOfNames As Long ' Index in ElementNames array. Used to access _ControlCache +Dim vControl As Variant ' Alias of _ControlCache entry +Dim oView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Dim i As Long +Const cstThisSub = "SFDocuments.FormControl.Controls" +Const cstSubArgs = "[ControlName]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set Controls = Nothing + +Check: + If IsMissing(ControlName) Or IsEmpty(ControlName) Then ControlName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTABLECONTROL Then GoTo Catch + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING) Then GoTo Finally + End If + +Try: + ' Collect all control names if not yet done + If UBound(_ControlNames) < 0 Then + _ControlNames = _ControlModel.getElementNames() + If UBound(_ControlNames) >= 0 Then + ReDim _ControlCache(0 To UBound(_ControlNames)) + End If + End If + + ' Return the list of controls or a FormControl instance + If Len(ControlName) = 0 Then + Controls = _ControlNames + + Else + + If Not _ControlModel.hasByName(ControlName) Then GoTo CatchNotFound + lIndexOfNames = ScriptForge.SF_Array.IndexOf(_ControlNames, ControlName, CaseSensitive := True) + ' Reuse cache when relevant + vControl = _ControlCache(lIndexOfNames) + + If IsEmpty(vControl) Then + ' Not in cache => Create the new form control class instance + Set oControl = New SF_FormControl + With oControl + ._Name = ControlName + Set .[Me] = oControl + Set .[_Parent] = [Me] + ._ParentIsTable = True + ._IndexOfNames = lIndexOfNames + ._FormName = _FormName + Set ._ParentForm = _ParentForm + ' Get model and view of the current control + Set ._ControlModel = _ControlModel.getByName(ControlName) + ._ImplementationName = ._ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? + ' Bypass to find the control view: cannot be done from the top component + If Not IsNull(_ControlView) Then ' Anticipate absence of ControlView in table controls when edit mode + For i = 0 to _ControlView.getCount() - 1 + Set oView = _ControlView.GetByIndex(i) + If Not IsNull(oView) Then + If oView.getModel.Name = ControlName Then + Set ._ControlView = oView + Exit For + End If + End If + Next i + End If + ._Initialize() + End With + Else + Set oControl = vControl + End If + + Set Controls = oControl + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Utils._Validate(ControlName, "ControlName", V_STRING, _ControlModel.getElementNames()) + GoTo Finally +End Function ' SFDocuments.SF_FormControl.Controls + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myControl.GetProperty("MyProperty") + +Dim vDefault As Variant ' Default value when property not applicable on control type +Const cstThisSub = "SFDocuments.FormControl.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + ' FormControl properties are far from applicable to all control types + ' Getting a property must never abort to not interfere with the Basic IDE watch function + ' Hence a default value must be provided + Select Case UCase(PropertyName) + Case UCase("Default") : vDefault = False + Case UCase("DefaultValue") : vDefault = Null + Case UCase("Enabled") : vDefault = False + Case UCase("ListCount") : vDefault = 0 + Case UCase("ListIndex") : vDefault = -1 + Case UCase("Locked") : vDefault = False + Case UCase("MultiSelect") : vDefault = False + Case UCase("Parent") : vDefault = Nothing + Case UCase("Required") : vDefault = False + Case UCase("TripleState") : vDefault = False + Case UCase("Value") : vDefault = Empty + Case UCase("Visible") : vDefault = True + Case UCase("XControlModel") : vDefault = Nothing + Case UCase("XControlView") : vDefault = Nothing + Case Else : vDefault = "" + End Select + + GetProperty = _PropertyGet(PropertyName, vDefault) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_FormControl.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the FormControl service as an array + + Methods = Array( _ + "AddSubNode" _ + , "AddSubTree" _ + , "CreateRoot" _ + , "FindNode" _ + , "SetFocus" _ + , "WriteLine" _ + ) + +End Function ' SFDocuments.SF_FormControl.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the FormControl class as an array + + Properties = Array( _ + "Action" _ + , "Cancel" _ + , "Caption" _ + , "ControlSource" _ + , "ControlType" _ + , "Default" _ + , "DefaultValue" _ + , "Enabled" _ + , "Format" _ + , "ListCount" _ + , "ListIndex" _ + , "ListSource" _ + , "ListSourceType" _ + , "Locked" _ + , "MultiSelect" _ + , "Name" _ + , "OnActionPerformed" _ + , "OnAdjustmentValueChanged" _ + , "OnApproveAction" _ + , "OnApproveReset" _ + , "OnApproveUpdate" _ + , "OnChanged" _ + , "OnErrorOccurred" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnItemStateChanged" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "OnResetted" _ + , "OnTextChanged" _ + , "OnUpdated" _ + , "Parent" _ + , "Picture" _ + , "Required" _ + , "Text" _ + , "TipText" _ + , "TripleState" _ + , "Value" _ + , "Visible" _ + , "XControlModel" _ + , "XControlView" _ + ) + +End Function ' SFDocuments.SF_FormControl.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetFocus() As Boolean +''' Set the focus on the current Control instance +''' Probably called from after an event occurrence +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' Dim oDoc As Object, oForm As Object, oControl As Object +''' Set oDoc = CreateScriptService("SFDocuments.Document", ThisComponent) +''' Set oForm = oDoc.Forms(0) +''' Set oControl = oForm.Controls("thisControl") +''' oControl.SetFocus() + +Dim bSetFocus As Boolean ' Return value +Dim iColPosition As Integer ' Position of control in table +Dim oTableModel As Object ' XControlModel of parent table +Dim oControl As Object ' com.sun.star.awt.XControlModel +Dim i As Integer, j As Integer +Const cstThisSub = "SFDocuments.FormControl.SetFocus" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSetFocus = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _ParentForm._IsStillAlive() Then GoTo Finally + End If + +Try: + If Not IsNull(_ControlView) Then + If _ParentIsTable Then ' setFocus() method does not work on controlviews in table control ?!? + ' Find the column position of the current instance in the parent table control + iColPosition = -1 + Set oTableModel = [_Parent]._ControlModel + j = -1 + For i = 0 To oTableModel.Count - 1 + Set oControl = oTableModel.getByIndex(i) + If Not oControl.Hidden Then j = j + 1 ' Skip hidden columns + If oControl.Name = _Name Then + iColPosition = j + Exit For + End If + Next i + If iColPosition >= 0 Then + [_Parent]._ControlView.setFocus() 'Set first focus on table control itself + [_Parent]._ControlView.setCurrentColumnPosition(iColPosition) 'Deprecated but no alternative found + End If + Else + _ControlView.setFocus() + End If + bSetFocus = True + End If + bSetFocus = True + +Finally: + SetFocus = bSetFocus + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFControls.SF_FormControl.SetFocus + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.FormControl.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_FormControl.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FormatsList() As Variant +''' Return the allowed format entries as a zero-based array for Date and Time control types + +Dim vFormats() As Variant ' Return value + + Select Case _ControlType + Case CTLDATEFIELD + vFormats = Array( _ + "Standard (short)" _ + , "Standard (short YY)" _ + , "Standard (short YYYY)" _ + , "Standard (long)" _ + , "DD/MM/YY" _ + , "MM/DD/YY" _ + , "YY/MM/DD" _ + , "DD/MM/YYYY" _ + , "MM/DD/YYYY" _ + , "YYYY/MM/DD" _ + , "YY-MM-DD" _ + , "YYYY-MM-DD" _ + ) + Case CTLTIMEFIELD + vFormats = Array( _ + "24h short" _ + , "24h long" _ + , "12h short" _ + , "12h long" _ + ) + Case Else + vFormats = Array() + End Select + + _FormatsList = vFormats + +End Function ' SFDocuments.SF_FormControl._FormatsList + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDocuments.SF_FormControl._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnActionPerformed") + _GetListener = "XActionListener" + Case UCase("OnAdjustmentValueChanged") + _GetListener = "XAdjustmentListener" + Case UCase("OnApproveAction") + _GetListener = "XApproveActionListener" + Case UCase("OnApproveReset"), UCase("OnResetted") + _GetListener = "XResetListener" + Case UCase("OnApproveUpdate"), UCase("OnUpdated") + _GetListener = "XUpdateListener" + Case UCase("OnChanged") + _GetListener = "XChangeListener" + Case UCase("OnErrorOccurred") + _GetListener = "XErrorListener" + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnItemStateChanged") + _GetListener = "XItemListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case UCase("OnTextChanged") + _GetListener = "XTextListener" + End Select + +End Function ' SFDocuments.SF_FormControl._GetListener + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Complete the object creation process: +''' - Initialization of private members +''' - Collection of specific attributes +''' - Synchronization with parent form instance + +Dim vControlTypes As Variant ' Array of control types ordered by the ClassId property of XControlModel - 2 +Const acHiddenControl = 13 ' Class Id of an hidden control: has no ControlView + + vControlTypes = array( CTLBUTTON _ + , CTLRADIOBUTTON _ + , CTLIMAGEBUTTON _ + , CTLCHECKBOX _ + , CTLLISTBOX _ + , CTLCOMBOBOX _ + , CTLGROUPBOX _ + , CTLTEXTFIELD _ + , CTLFIXEDTEXT _ + , CTLTABLECONTROL _ + , CTLFILECONTROL _ + , CTLHIDDENCONTROL _ + , CTLIMAGECONTROL _ + , CTLDATEFIELD _ + , CTLTIMEFIELD _ + , CTLNUMERICFIELD _ + , CTLCURRENCYFIELD _ + , CTLPATTERNFIELD _ + , CTLSCROLLBAR _ + , CTLSPINBUTTON _ + , CTLNAVIGATIONBAR _ + ) + +Try: + ' _implementationName is set elsewhere for controls in table control + If Len(_ImplementationName) = 0 Then _ImplementationName = ScriptForge.SF_Session.UnoObjectType(_ControlModel) + _ClassId = _ControlModel.ClassId + + ' Identify the control type, ignore subforms and pay attention to formatted fields + If ScriptForge.SF_Session.HasUnoproperty(_ControlModel, "ClassId") Then ' All control types have a ClassId property except subforms + _ControlType = vControlTypes(_ClassId - 2) + ' Formatted fields belong to the TextField family + If _ControlType = CTLTEXTFIELD Then + If _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper" _ + Or _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper_ForcedFormatted" _ + Or _ImplementationName = "com.sun.star.form.component.FormattedField" Then ' When in table control + _ControlType = CTLFORMATTEDFIELD + End If + End If + Else + Exit Sub ' Ignore subforms, should not happen + End If + + With [_Parent] + ' Set control view if not set yet + If IsNull(_ControlView) Then + If _ClassId > 0 And _ClassId <> acHiddenControl Then ' No view on hidden controls + If IsNull(._FormDocument) Then ' Usual document + Set _ControlView = ._Component.CurrentController.getControl(_ControlModel) + Else ' Base form document + Set _ControlView = ._FormDocument.Component.CurrentController.getControl(_ControlModel) + End If + End If + End If + End With + + ' Store the SF_FormControl object in the parent cache + Set _Parent._ControlCache(_IndexOfNames) = [Me] + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_FormControl._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _ListboxBound() As Boolean +''' Return True if the actual control, which is a listbox, has a bound column +''' Called before setting the value of a listbox, i.e. the value to be rewritten in the underlying table data +''' The existence of a bound column is derived from the comparison between StringItemList and ValueItemList +''' String ... : the strings displayed in the list box +''' Value ... : the database values +''' If they are different, then there is a bound column + +Dim bListboxBound As Boolean ' Return value +Dim vValue() As Variant ' Alias of the control model ValueItemList +Dim vString() As Variant ' Alias of the control model StringItemList +Dim i As Long + + bListboxBound = False + + With _ControlModel + If Not IsNull(.ValueItemList) _ + And .DataField <> "" _ + And Not IsNull(.BoundField) _ + And ScriptForge.SF_Array.Contains(Array( _ + com.sun.star.form.ListSourceType.TABLE _ + , com.sun.star.form.ListSourceType.QUERY _ + , com.sun.star.form.ListSourceType.SQL _ + , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ + ), .ListSourceType) Then + If IsArray(.ValueItemList) Then + vValue = .ValueItemList + vString = .StringItemList + For i = 0 To UBound(vValue) + If VarType(vValue(i)) <> VarType(vString(i)) Then + bListboxBound = True + ElseIf vValue(i) <> vString(i) Then + bListboxBound = True + End If + If bListboxBound Then Exit For + Next i + End If + End If + End With + + _ListboxBound = bListboxBound + +End Function ' _ListboxBound V0.9.0 + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvDefault As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property +''' pvDefault: the value returned when the property is not applicable on the control's type +''' Getting a non-existing property for a specific control type should +''' not generate an error to not disrupt the Basic IDE debugger + +Dim vGet As Variant ' Return value +Static oSession As Object ' Alias of SF_Session +Dim vSelection As Variant ' Alias of Model.SelectedItems or Model.Selection +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim vDate As Variant ' Date after conversion from com.sun.star.util.Date or com.sun.star.util.Time +Dim vValues As Variant ' Array of listbox values +Dim oControlEvents As Object ' com.sun.star.container.XNameContainer +Dim sEventName As String ' Internal event name +Const cstUnoUrl = ".uno:FormController/" +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDocuments.FormControl.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _ParentForm._IsStillAlive() Then GoTo Finally + + If IsMissing(pvDefault) Or IsEmpty(pvDefault) Then pvDefault = Null + _PropertyGet = pvDefault + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("Action") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "ButtonType") Then + Select Case _ControlModel.ButtonType + Case com.sun.star.form.FormButtonType.PUSH : _PropertyGet = "none" + Case com.sun.star.form.FormButtonType.SUBMIT : _PropertyGet = "submitForm" + Case com.sun.star.form.FormButtonType.RESET : _PropertyGet = "resetForm" + Case com.sun.star.form.FormButtonType.URL + ' ".uno:FormController/moveToFirst" + If Left(_ControlModel.TargetURL, Len(cstUnoUrl)) = cstUnoUrl Then + _PropertyGet = Mid(_ControlModel.TargetURL, Len(cstUnoUrl) + 1) + ElseIf Left(_ControlModel.TargetURL, 4) = "http" Then + _PropertyGet = "openWebPage" + ElseIf Left(_ControlModel.TargetURL, 4) = "file" Then + _PropertyGet ="openDocument" + End If + End Select + End If + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If oSession.HasUNOProperty(_ControlModel, "Label") Then _PropertyGet = _ControlModel.Label + Case Else : GoTo CatchType + End Select + Case UCase("ControlSource") + Select Case _ControlType + Case CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFORMATTEDFIELD, CTLIMAGECONTROL, CTLLISTBOX _ + , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLRADIOBUTTON, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "DataField") Then _PropertyGet = _ControlModel.DataField + Case Else : GoTo CatchType + End Select + Case UCase("ControlType") + _PropertyGet = _ControlType + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _PropertyGet = _ControlModel.DefaultButton + Case Else : GoTo CatchType + End Select + Case UCase("DefaultValue") + Select Case _ControlType + Case CTLCHECKBOX, CTLRADIOBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultState") Then _PropertyGet = _ControlModel.DefaultState + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultText") Then _PropertyGet = _ControlModel.DefaultText + Case CTLCURRENCYFIELD, CTLNUMERICFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultValue") Then _PropertyGet = _ControlModel.DefaultValue + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultDate") Then + If Not IsEmpty(_ControlModel.DefaultDate) Then + With _ControlModel.DefaultDate + vDate = DateSerial(.Year, .Month, .Day) + End With + _PropertyGet = vDate + End If + End If + Case CTLFORMATTEDFIELD + If oSession.HasUNOProperty(_ControlModel, "EffectiveDefault") Then _PropertyGet = _ControlModel.EffectiveDefault + Case CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "DefaultSelection") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + vList = _ControlModel.DefaultSelection + If IsArray(vList) Then + If UBound(vList) >= LBound(vList) Then ' Is array initialized ? + lIndex = UBound(_ControlModel.StringItemList) + If vList(0) >= 0 And vList(0) <= lIndex Then _PropertyGet = _ControlModel.StringItemList(vList(0)) + ' Only first default value is considered + End If + End If + End If + Case CTLSPINBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultSpinValue") Then _PropertyGet = _ControlModel.DefaultSpinValue + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "DefaultTime") Then + If Not IsEmpty(_ControlModel.DefaultTime) Then + With _ControlModel.DefaultTime + vDate = TimeSerial(.Hours, .Minutes, .Seconds) + End With + _PropertyGet = vDate + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _PropertyGet = _ControlModel.Enabled + End Select + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then _PropertyGet = _FormatsList()(_ControlModel.DateFormat) + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then _PropertyGet = _FormatsList()(_ControlModel.TimeFormat) + Case CTLFORMATTEDFIELD + If oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") And oSession.HasUNOProperty(_ControlModel, "FormatKey") Then + _PropertyGet = _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListCount") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "StringItemList") Then _PropertyGet = UBound(_ControlModel.StringItemList) + 1 + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + Select Case _ControlType + Case CTLCOMBOBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + _PropertyGet = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, _ControlModel.Text, CaseSensitive := True) + End If + Case CTLLISTBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + vSelection = _ControlModel.SelectedItems + If UBound(vSelection) >= 0 Then _PropertyGet = vSelection(0) + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "ListSource") Then + With com.sun.star.form.ListSourceType + Select Case _ControlModel.ListSourceType + Case .VALUELIST _ + , .TABLEFIELDS + If IsArray(_ControlModel.StringItemList) Then vValues = _ControlModel.StringItemList Else vValues = Array(_ControlModel.StringItemList) + Case .TABLE _ + , .QUERY _ + , .SQL _ + , .SQLPASSTHROUGH + If IsArray(_ControlModel.ListSource) Then vValues = _ControlModel.ListSource Else vValues = Array(_ControlModel.ListSource) + End Select + End With + _PropertyGet = Join(vValues, ";") + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListSourceType") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "ListSourceType") Then _PropertyGet = _ControlModel.ListSourceType + Case Else : GoTo CatchType + End Select + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLIMAGECONTROL _ + , CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _PropertyGet = _ControlModel.ReadOnly + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + _PropertyGet = _ControlModel.MultiSelection + ElseIf oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: gridcontrols only TBC ?? + _PropertyGet = _ControlModel.MultiSelectionSimpleMode + End If + Case Else : GoTo CatchType + End Select + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset"), UCase("OnApproveUpdate") _ + , UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained"), UCase("OnFocusLost") _ + , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted") _ + , UCase("OnTextChanged"), UCase("OnUpdated") + If IsNull(_ControlModel) Then _PropertyGet = "" Else _PropertyGet = SF_Register._GetEventScriptCode(_ControlModel, psProperty, _Name) + Case UCase("Parent") + Set _PropertyGet = [_Parent] + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGEBUTTON, CTLIMAGECONTROL + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _PropertyGet = ScriptForge.SF_FileSystem._ConvertFromUrl(_ControlModel.ImageURL) + Case Else : GoTo CatchType + End Select + Case UCase("Required") + Select Case _ControlType + Case CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLIMAGECONTROL, CTLLISTBOX, CTLNUMERICFIELD _ + , CTLPATTERNFIELD, CTLRADIOBUTTON, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUnoProperty(_ControlModel, "InputRequired") Then _PropertyGet = _ControlModel.InputRequired + Case Else : GoTo CatchType + End Select + Case UCase("Text") + Select Case _ControlType + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "Date") _ + And oSession.HasUNOProperty(_ControlModel, "FormatKey") _ + And oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") Then + If Not IsEmpty(_ControlModel.Date) Then + With _ControlModel.Date + vDate = DateSerial(.Year, .Month, .Day) + End With + _PropertyGet = Format(vDate, _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString) + End If + End If + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "Text") Then + If Not IsEmpty(_ControlModel.Time) Then + With _ControlModel.Time + vDate = TimeSerial(.Hours, .Minutes, .Seconds) + End With + _PropertyGet = Format(vDate, "HH:MM:SS") + End If + End If + Case CTLCOMBOBOX, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLPATTERNFIELD, CTLTEXTFIELD + If oSession.HasUnoProperty(_ControlModel, "Text") Then _PropertyGet = _ControlModel.Text + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _PropertyGet = _ControlModel.HelpText + End Select + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _PropertyGet = _ControlModel.TriState + Case Else : GoTo CatchType + End Select + Case UCase("Value") ' Default values are set here by control type, not in the 2nd argument (pvDefault) + vGet = pvDefault + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + vGet = False + If oSession.HasUnoProperty(_ControlModel, "Toggle") Then + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = _ControlModel.State Else vGet = 2 + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String + If oSession.HasUnoProperty(_ControlModel, "Text") Then vGet = _ControlModel.Text Else vGet = "" + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If oSession.HasUnoProperty(_ControlModel, "Value") Then vGet = _ControlModel.Value Else vGet = 0 + Case CTLDATEFIELD 'Date + vGet = CDate(1) + If oSession.HasUnoProperty(_ControlModel, "Date") Then + If VarType(_ControlModel.Date) = ScriptForge.V_OBJECT Then ' com.sun.star.util.Date + With _ControlModel.Date + vDate = DateSerial(.Year, .Month, .Day) + End With + vGet = vDate + Else ' .Date = Empty + End If + End If + Case CTLFORMATTEDFIELD 'String or numeric + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then vGet = _ControlModel.EffectiveValue Else vGet = "" + Case CTLHIDDENCONTROL 'String + If oSession.HasUnoProperty(_ControlModel, "HiddenValue") Then vGet = _ControlModel.HiddenValue Else vGet = "" + Case CTLLISTBOX 'String or array of strings depending on MultiSelection + ' StringItemList is the list of the items displayed in the box + ' ValueItemList is the list of the values in the underlying database field + ' SelectedItems is the list of the indexes in StringItemList of the selected items + ' It can go beyond the limits of StringItemList + ' It can contain multiple values even if the listbox is not multiselect + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _ + And oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + vSelection = _ControlModel.SelectedItems + ' The list of allowed values depends on the existence of a bound column + If _ListBoxBound() Then vList = _ControlModel.ValueItemList Else vList = _ControlModel.StringItemList + If _ControlModel.MultiSelection Then vValues = Array() + For i = 0 To UBound(vSelection) + lIndex = vSelection(i) + If lIndex >= 0 And lIndex <= UBound(vList) Then + If Not _ControlModel.MultiSelection Then + vValues = vList(lIndex) + Exit For + End If + vValues = ScriptForge.SF_Array.Append(vValues, vList(lIndex)) + End If + Next i + vGet = vValues + Else + vGet = "" + End If + Case CTLRADIOBUTTON 'Boolean + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) Else vGet = False + Case CTLSCROLLBAR 'Numeric + vGet = 0 + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then + If Not IsEmpty(_ControlModel.ScrollValue) Then vGet = _ControlModel.ScrollValue + End If + Case CTLSPINBUTTON + If oSession.HasUnoProperty(_ControlModel, "SpinValue") Then vGet = _ControlModel.SpinValue Else vGet = 0 + Case CTLTIMEFIELD + vGet = CDate(0) + If oSession.HasUnoProperty(_ControlModel, "Time") Then + If VarType(_ControlModel.Time) = ScriptForge.V_OBJECT Then ' com.sun.star.Util.Time + With _ControlModel.Time + vDate = TimeSerial(.Hours, .Minutes, .Seconds) + End With + vGet = vDate + Else ' .Time = Empty + End If + End If + Case Else : GoTo CatchType + End Select + _PropertyGet = vGet + Case UCase("Visible") + If oSession.HasUnoMethod(_ControlView, "isVisible") Then _PropertyGet = CBool(_ControlView.isVisible()) + Case UCase("XControlModel") + Set _PropertyGet = _ControlModel + Case UCase("XControlView") + Set _PropertyGet = _ControlView + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + GoTo Finally +End Function ' SFDocuments.SF_FormControl._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim sFormName As String ' Full form identification for error messages +Dim vSet As Variant ' Value to set in UNO model or view property +Dim vActions As Variant ' Action property: list of available actions +Dim sAction As String ' A single action +Dim vFormats As Variant ' Format property: output of _FormatsList() +Dim iFormat As Integer ' Format property: index in vFormats +Dim vSelection As Variant ' Alias of Model.SelectedItems +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim oDatabase As Object ' The database object related to the parent form of the control instance +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.FormControl.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _ParentForm._IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("Action") + Select Case _ControlType + Case CTLBUTTON + vActions = Array("none", "submitForm", "resetForm", "refreshForm", "moveToFirst", "moveToLast", "moveToNext", "moveToPrev" _ + , "saveRecord", "moveToNew", "deleteRecord", "undoRecord") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Action", ScriptForge.V_STRING, vActions) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "ButtonType") Then + sAction = vActions(ScriptForge.SF_Array.IndexOf(vActions, pvValue, CaseSensitive := False)) + _ControlModel.TargetURL = "" + Select Case sAction + Case "none" : vSet = com.sun.star.form.FormButtonType.PUSH + Case "submitForm" : vSet = com.sun.star.form.FormButtonType.SUBMIT + Case "resetForm" : vSet = com.sun.star.form.FormButtonType.RESET + Case Else + vSet = com.sun.star.form.FormButtonType.URL + _ControlModel.TargetURL = ".uno:FormController/" & sAction + End Select + _ControlModel.ButtonType = vSet + End If + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Caption", V_STRING) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "Label") Then _ControlModel.Label = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Default", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _ControlModel.DefaultButton = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If Not ScriptForge.SF_Utils._Validate(pvValue, "Enabled", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _ControlModel.Enabled = pvValue + End Select + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD, CTLTIMEFIELD + vFormats = _FormatsList() + If Not ScriptForge.SF_Utils._Validate(pvValue, "Format", V_STRING, vFormats) Then GoTo Finally + iFormat = ScriptForge.SF_Array.IndexOf(vFormats, pvValue, CaseSensitive := False) + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then + _ControlModel.DateFormat = iFormat + ElseIf oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then + _ControlModel.TimeFormat = iFormat + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListIndex", ScriptForge.V_NUMERIC) Then GoTo Finally + Select Case _ControlType + Case CTLCOMBOBOX + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + If pvValue >= 0 And pvValue <= UBound(_ControlModel.StringItemList) Then _ControlModel.Text = _ControlModel.StringItemList(CInt(pvValue)) + End If + Case CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") Then _ControlModel.SelectedItems = Array(CInt(pvValue)) + Case Else : GoTo CatchType + End Select + Case UCase("ListSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "ListSource") Then + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then Goto Finally + With com.sun.star.form.ListSourceType + Select Case _ControlModel.ListSourceType + Case .QUERY _ + , .TABLE _ + , .TABLEFIELDS + Set oDatabase = _ParentForm.GetDatabase() + If _ControlModel.ListSourceType = .QUERY Then vList = oDatabase.Queries Else vList = oDatabase.Tables + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING, vList) Then Goto Finally + If _ControlType = CTLCOMBOBOX Then _ControlModel.ListSource = pvValue Else _ControlModel.ListSource = Array(pvValue) + _ControlModel.refresh() + Case .SQL + Set oDatabase = _ParentForm.GetDatabase() + If _ControlType = CTLCOMBOBOX Then _ControlModel.ListSource = oDatabase._ReplaceSquareBrackets(pvValue) Else _ControlModel.ListSource = Array(oDatabase._ReplaceSquareBrackets(pvValue)) + _ControlModel.refresh() + Case .VALUELIST ' ListBox only ! + _ControlModel.ListSource = Split(pvValue, ";") + _ControlModel.StringItemList = _ControlModel.ListSource + Case .SQLPASSTHROUGH + If _ControlType = CTLCOMBOBOX Then _ControlModel.ListSource = pvValue Else _ControlModel.ListSource = Array(pvValue) + _ControlModel.refresh() + End Select + End With + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListSourceType") + With com.sun.star.form.ListSourceType + Select Case _ControlType + Case CTLCOMBOBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListSourceType", ScriptForge.V_NUMERIC, Array( _ + .TABLE _ + , .QUERY _ + , .SQL _ + , .SQLPASSTHROUGH _ + , .TABLEFIELDS _ + )) Then GoTo Finally + Case CTLLISTBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListSourceType", ScriptForge.V_NUMERIC, Array( _ + .VALUELIST _ + , .TABLE _ + , .QUERY _ + , .SQL _ + , .SQLPASSTHROUGH _ + , .TABLEFIELDS _ + )) Then GoTo Finally + Case Else : GoTo CatchType + End Select + End With + If oSession.HasUnoProperty(_ControlModel, "ListSourceType") Then _ControlModel.ListSourceType = pvValue + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLIMAGECONTROL _ + , CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Locked", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _ControlModel.ReadOnly = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "MultiSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then _ControlModel.MultiSelection = pvValue + If oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then _ControlModel.MultiSelectionSimpleMode = pvValue + If oSession.HasUnoProperty(_ControlModel, "SelectedItems") Then + ' Cancel selections when MultiSelect becomes False + If Not pvValue And UBound(_ControlModel.SelectedItems) > 0 Then + lIndex = _ControlModel.SelectedItems(0) + _ControlModel.SelectedItems = Array(lIndex) + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset"), UCase("OnApproveUpdate") _ + , UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained"), UCase("OnFocusLost") _ + , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted") _ + , UCase("OnTextChanged"), UCase("OnUpdated") + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then Goto Finally + If Not IsNull(_ControlModel) Then + bSet = SF_Register._RegisterEventScript(_ControlModel _ + , psProperty _ + , _GetListener(psProperty) _ + , pvValue _ + , _Name _ + ) + End If + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGEBUTTON, CTLIMAGECONTROL + If Not ScriptForge.SF_Utils._ValidateFile(pvValue, "Picture") Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _ControlModel.ImageURL = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue) + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + Select Case _ControlType + Case CTLHIDDENCONTROL : GoTo CatchType + Case Else + If Not ScriptForge.SF_Utils._Validate(pvValue, "TipText", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _ControlModel.HelpText = pvValue + End Select + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "TripleState", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _ControlModel.TriState = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Value") + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Toggle") And oSession.HasUnoProperty(_ControlModel, "State") Then + _ControlModel.State = Iif(pvValue, 1, 0) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(ScriptForge.V_BOOLEAN, ScriptForge.V_NUMERIC), Array(0, 1, 2, True, False)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then + If VarType(pvValue) = ScriptForge.V_BOOLEAN Then pvValue = Iif(pvValue, 1, 0) + _ControlModel.State = pvValue + End If + Case CTLCOMBOBOX + If oSession.HasUnoProperty(_ControlModel, "Text") And oSession.HasUnoProperty(_ControlModel, "StringItemList") Then + If pvValue <> "" Then + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING, _ControlModel.StringItemList) Then Goto Finally + End If + _ControlModel.Text = pvValue + End If + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Value") Then _ControlModel.Value = pvValue + Case CTLDATEFIELD 'Date + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Date") Then + Set vSet = New com.sun.star.util.Date + vSet.Year = Year(pvValue) + vSet.Month = Month(pvValue) + vSet.Day = Day(pvValue) + _ControlModel.Date = vSet + End If + Case CTLFILECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Text") Then _ControlModel.Text = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue) + Case CTLFORMATTEDFIELD 'String or numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then _ControlModel.EffectiveValue = pvValue + Case CTLHIDDENCONTROL 'String + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "HiddenValue") Then _ControlModel.HiddenValue = pvValue + Case CTLLISTBOX 'String or number - Only a single value may be set + ' StringItemList is the list of the items displayed in the box + ' ValueItemList is the list of the values in the underlying database field + ' SelectedItems is the list of the indexes in StringItemList of the selected items + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") Then + ' Setting the value on a listbox is allowed only if single value and value in the list + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + ' The list of allowed values depends on the existence of a bound column + If _ListboxBound() Then vList = _ControlModel.ValueItemList Else vList = _ControlModel.StringItemList + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", , vList) Then GoTo Finally + _ControlModel.SelectedItems = Array(ScriptForge.SF_Array.IndexOf(vList, pvValue, CaseSensitive := True)) + End If + Case CTLPATTERNFIELD, CTLTEXTFIELD 'String + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Text") Then _ControlModel.Text = pvValue + Case CTLRADIOBUTTON 'Boolean + ' A group of radio buttons is presumed sharing the same GroupName + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then _ControlModel.State = Iif(pvValue, 1, 0) + Case CTLSCROLLBAR 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMin") Then + If pvValue < _ControlModel.ScrollValueMin Then pvValue = _ControlModel.ScrollValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMax") Then + If pvValue > _ControlModel.ScrollValueMax Then pvValue = _ControlModel.ScrollValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then _ControlModel.ScrollValue = pvValue + Case CTLSPINBUTTON 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "SpinValueMin") Then + If pvValue < _ControlModel.SpinValueMin Then pvValue = _ControlModel.SpinValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "SpinValueMax") Then + If pvValue > _ControlModel.SpinValueMax Then pvValue = _ControlModel.SpinValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "SpinValue") Then _ControlModel.SpinValue = pvValue + Case CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Time") Then + Set vSet = New com.sun.star.util.Time + vSet.Hours = Hour(pvValue) + vSet.Minutes = Minute(pvValue) + vSet.Seconds = Second(pvValue) + _ControlModel.Time = vSet + End If + Case Else : GoTo CatchType + End Select + ' FINAL COMMITMENT + If oSession.HasUNOMethod(_ControlModel, "commit") Then _ControlModel.commit() ' f.i. checkboxes have no commit method ?? + Case UCase("Visible") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Visible", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoMethod(_ControlView, "setVisible") Then + If pvValue Then _ControlModel.EnableVisible = True + _ControlView.setVisible(pvValue) + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bSet = False + GoTo Finally +CatchType: + If Len(_ParentForm._FormDocumentName) > 0 Then sFormName = _ParentForm._FormDocumentName & "." Else sFormName = "" + ScriptForge.SF_Exception.RaiseFatal(FORMCONTROLTYPEERROR, _Name, sFormName & _FormName, _ControlType, psProperty) + GoTo Finally +End Function ' SFDocuments.SF_FormControl._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[FORMCONTROL]: Name, Type (formname) + _Repr = "[FORMCONTROL]: " & _Name & ", " & _ControlType & " (" & _FormName & ")" + +End Function ' SFDocuments.SF_FormControl._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_FORMCONTROL + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Register.xba b/wizards/source/sfdocuments/SF_Register.xba new file mode 100644 index 000000000..5baf37afb --- /dev/null +++ b/wizards/source/sfdocuments/SF_Register.xba @@ -0,0 +1,546 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ================================================================= DEFINITIONS + +''' Strategy for management of Form and FormControl events: +''' ------------------------------------------------------ +''' At the contrary of Dialogs and DialogControls, which are always started from some code, +''' Forms and FormControls will be initiated most often by the user, even if the SFDocuments library +''' allows to start forms programmatically +''' +''' For Forms started programmatically, the corresponding objects are built top-down +''' Event management of forms and their controls requires to being able to rebuild Form +''' and FormControl objects bottom-up +''' +''' To avoid multiple rebuilds requested by multiple events, +''' 1. The active form objects are cached in a global array of _FormCache types +''' 2. FormControl objects are cached in Form objects +''' 3. The bottom-up rebuild is executed only once, at instance creation + +Type _FormCache + Terminated As Boolean + XUnoForm As Object + BasicForm As Object +End Type + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Document", "SFDocuments.SF_Register._NewDocument") ' Reference to the function initializing the service + .RegisterService("Base", "SFDocuments.SF_Register._NewDocument") ' Same reference, distinction is made inside the function + .RegisterService("Calc", "SFDocuments.SF_Register._NewDocument") ' Same reference, distinction is made inside the function + .RegisterService("Writer", "SFDocuments.SF_Register._NewDocument") ' Same reference, distinction is made inside the function + .RegisterEventManager("DocumentEvent", "SFDocuments.SF_Register._EventManager") ' Reference to the events manager + .RegisterEventManager("FormEvent", "SFDocuments.SF_Register._FormEventManager")' Reference to the form and controls events manager + End With + +End Sub ' SFDocuments.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _AddFormToCache(ByRef pvUnoForm As Object _ + , ByRef pvBasicForm As Object _ + ) As Long +''' Add a new entry in the cache array with the references of the actual Form +''' If relevant, the last entry of the cache is reused. +''' The cache is located in the global _SF_ variable +''' Args: +''' pvUnoForm: com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +''' pvBasicForm: its corresponding Basic object +''' Returns: +''' The index of the new or modified entry + +Dim vCache As New _FormCache ' Entry to be added +Dim lIndex As Long ' UBound of _SF_.SFForms +Dim vCacheArray As Variant ' Alias of _SF_.SFForms + +Try: + vCacheArray = _SF_.SFForms + + If IsEmpty(vCacheArray) Then vCacheArray = Array() + lIndex = UBound(vCacheArray) + If lIndex < LBound(vCacheArray) Then + ReDim vCacheArray(0 To 0) + lIndex = 0 + ElseIf Not vCacheArray(lIndex).Terminated Then ' Often last entry can be reused + lIndex = lIndex + 1 + ReDim Preserve vCacheArray(0 To lIndex) + End If + + With vCache + .Terminated = False + Set .XUnoForm = pvUnoForm + Set .BasicForm = pvBasicForm + End With + Set vCacheArray(lIndex) = vCache + + _SF_.SFForms = vCacheArray + +Finally: + _AddFormToCache = lIndex + Exit Function +End Function ' SFDocuments.SF_Register._AddFormToCache + +REM ----------------------------------------------------------------------------- +Private Sub _CleanCacheEntry(ByVal plIndex As Long) +''' Clean the plIndex-th entry in the Forms cache +''' Args: +''' plIndex: must fit within the actual boundaries of the cache, otherwise the request is ignored + +Dim vCache As New _FormCache ' Cleaned entry + + With _SF_ + If Not IsArray(.SFForms) Then Exit Sub + If plIndex < LBound(.SFForms) Or plIndex > UBound(.SFForms) Then Exit Sub + + With vCache + .Terminated = True + Set .XUnoForm = Nothing + Set .BasicForm = Nothing + End With + .SFForms(plIndex) = vCache + End With + +Finally: + Exit Sub +End Sub ' SFDocuments.SF_Register._CleanCacheEntry + +REM ----------------------------------------------------------------------------- +Public Function _EventManager(Optional ByRef pvArgs As Variant) As Object +''' Returns a Document, Calc or Base object corresponding with the active component +''' which triggered the event in argument +''' This method should be triggered only thru the invocation of CreateScriptService +''' Args: +''' pvEvent: com.sun.star.document.DocumentEvent +''' Returns: +''' the output of a Document, Calc, ... service or Nothing +''' Example: +''' Sub TriggeredByEvent(ByRef poEvent As Object) +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.DocumentEvent", poEvent) +''' If Not IsNull(oDoc) Then +''' ' ... (a valid document has been identified) +''' End Sub + +Dim oSource As Object ' Return value +Dim vEvent As Variant ' Alias of pvArgs(0) + + ' Never abort while an event is processed + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Finally + Set oSource = Nothing + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vEvent = pvArgs(0) Else Set vEvent = Empty + If VarType(vEvent) <> ScriptForge.V_OBJECT Then GoTo Finally + +Try: + If ScriptForge.SF_Session.UnoObjectType(vEvent) = "com.sun.star.document.DocumentEvent" Then + Set oSource = SF_Register._NewDocument(vEvent.Source) + End If + +Finally: + Set _EventManager = oSource + Exit Function +End Function ' SFDocuments.SF_Register._EventManager + +REM ----------------------------------------------------------------------------- +Private Function _FindFormInCache(ByRef poForm As Object) As Object +''' Find the Form based on its XUnoForm +''' The Form must not be terminated +''' Returns: +''' The corresponding Basic Form part or Nothing + +Dim oBasicForm As Object ' Return value +Dim oCache As _FormCache ' Entry in the cache + + Set oBasicForm = Nothing + +Try: + With _SF_ + If Not IsEmpty(.SFForms) Then + For Each oCache In .SFForms + If EqualUnoObjects(poForm, oCache.XUnoForm) And Not oCache.Terminated Then + Set oBasicForm = oCache.BasicForm + Exit For + End If + Next oCache + End If + End With + +Finally: + Set _FindFormInCache = oBasicForm + Exit Function +End Function ' SFDocuments.SF_Register._FindFormInCache + +REM ----------------------------------------------------------------------------- +Public Function _FormEventManager(Optional ByRef pvArgs As Variant) As Object +''' Returns a Form or FormControl object corresponding with the form or control +''' which triggered the event in argument +''' This method should be triggered only thru the invocation of CreateScriptService +''' Args: +''' pvEvent: com.sun.star.lang.EventObject +''' Returns: +''' the output of a Form, FormControl service or Nothing +''' Example: +''' Sub TriggeredByEvent(ByRef poEvent As Object) +''' Dim oForm As Object +''' Set oForm = CreateScriptService("SFDocuments.FormEvent", poEvent) +''' If Not IsNull(oForm) Then +''' ' ... (a valid form or subform has been identified) +''' End Sub + +Dim oSource As Object ' Return value +Dim vEvent As Variant ' Alias of pvArgs(0) +Dim oControlModel As Object ' com.sun.star.awt.XControlModel +Dim oParent As Object ' com.sun.star.form.OGridControlModel or com.sun.star.comp.forms.ODatabaseForm +Dim sParentType As String ' "com.sun.star.form.OGridControlModel" or "com.sun.star.comp.forms.ODatabaseForm" +Dim oSFParent As Object ' The parent as a ScriptForge instance: SF_Form or SF_FormControl +Dim oSFForm As Object ' The grand-parent SF_Form instance +Dim oSession As Object : Set oSession = ScriptForge.SF_Session + + ' Never abort while an event is processed + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Finally + Set oSource = Nothing + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vEvent = pvArgs(0) Else Set vEvent = Empty + If VarType(vEvent) <> ScriptForge.V_OBJECT Then GoTo Finally + +Try: + If oSession.HasUnoProperty(vEvent, "Source") Then + + ' FORM EVENT + If oSession.UnoObjectType(vEvent.Source) = "com.sun.star.comp.forms.ODatabaseForm" Then + Set oSource = SF_Register._NewForm(vEvent.Source, pbForceInit := True) + + ' CONTROL EVENT + Else + ' A SF_FormControl instance is always created from its parent, either a form, a subform or a table control + Set oControlModel = vEvent.Source.Model ' The event source is a control view com.sun.star.awt.XControl + Set oParent = oControlModel.Parent + sParentType = oSession.UnoObjectType(oParent) + Select Case sParentType + Case "com.sun.star.form.OGridControlModel" + Set oSFForm = SF_Register._NewForm(oParent.Parent, pbForceInit := True) + Set oSFParent = oSFForm.Controls(oParent.Name) + Case "com.sun.star.comp.forms.ODatabaseForm" + Set oSFParent = SF_Register._NewForm(oParent, pbForceInit := True) + End Select + ' The final instance is derived from its parent instance + Set oSource = oSFParent.Controls(oControlModel.Name) + + End If + + End If + +Finally: + Set _FormEventManager = oSource + Exit Function +End Function ' SFDocuments.SF_Register._FormEventManager + +REM ----------------------------------------------------------------------------- +Public Function _GetEventScriptCode(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psName As String _ + ) As String +''' Extract from the parent of poObject the Basic script linked to psEvent. +''' Helper function common to forms and form controls +''' Args: +''' poObject: a com.sun.star.form.XForm or XControl object +''' psEvent: the "On..." name of the event +''' psName: the name of the object to be identified from the parent object +''' Returns: +''' The script to trigger when psEvent occurs +''' See Scripting Framework URI Specification : https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification + +Dim vEvents As Variant ' List of available events in the parent object + ' Array of com.sun.star.script.ScriptEventDescriptor +Dim sEvent As String ' The targeted event name +Dim oParent As Object ' The parent object +Dim lIndex As Long ' The index of the targeted event in the events list of the parent object +Dim sName As String ' The corrected UNO event name +Dim i As Long + + _GetEventScriptCode = "" + On Local Error GoTo Catch + If Not ScriptForge.SF_Session.HasUnoMethod(poObject, "getParent") Then GoTo Finally + +Try: + ' Find form index i.e. find control via getByIndex() + ' The name is known (= psName) but getByIndex() is not in the same sequence as getElementNames() + Set oParent = poObject.getParent() + lIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Then + lIndex = i + Exit For + End If + Next i + If lIndex < 0 Then GoTo Finally ' Not found, should not happen + + ' Find script triggered by event + vEvents = oParent.getScriptEvents(lIndex) ' Returns an array + ' Fix historical typo error + sEvent = Replace(LCase(Mid(psEvent, 3, 1)) & Mid(psEvent, 4), "errorOccurred", "errorOccured") + For i = 0 To UBound(vEvents) + If vEvents(i).EventMethod = sEvent Then + _GetEventScriptCode = vEvents(i).ScriptCode + Exit For + End If + Next i + +Finally: + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Register._GetEventScriptCode + +REM ----------------------------------------------------------------------------- +Public Function _NewDocument(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the (super) SF_Document class or of one of its subclasses (SF_Calc, ...) +' Args: +''' WindowName: see the definition of WindowName in the description of the UI service +''' If absent, the document is presumed to be in the active window +''' If WindowName is an object, it must be a component +''' (com.sun.star.lang.XComponent or com.sun.star.comp.dba.ODatabaseDocument) +''' Returns: the instance or Nothing + +Dim oDocument As Object ' Return value +Dim oSuperDocument As Object ' Companion superclass document +Dim vWindowName As Variant ' Alias of pvArgs(0) +Dim oEnum As Object ' com.sun.star.container.XEnumeration +Dim oComp As Object ' com.sun.star.lang.XComponent +Dim vWindow As Window ' A single component +Dim oUi As Object ' "UI" service +Dim bFound As Boolean ' True if the document is found on the desktop + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) ' Needed when _NewDocument called from _EventManager + If UBound(pvArgs) >= 0 Then vWindowName = pvArgs(0) Else vWindowName = "" + If Not ScriptForge.SF_Utils._Validate(vWindowName, "WindowName", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally + Set oDocument = Nothing + +Try: + Set oUi = ScriptForge.SF_Services.CreateScriptService("UI") + Select Case VarType(vWindowName) + Case V_STRING + If Len(vWindowName) > 0 Then + bFound = False + Set oEnum = StarDesktop.Components().createEnumeration + Do While oEnum.hasMoreElements + Set oComp = oEnum.nextElement + vWindow = oUi._IdentifyWindow(oComp) + With vWindow + ' Does the current window match the argument ? + If (Len(.WindowFileName) > 0 And .WindowFileName = ScriptForge.SF_FileSystem._ConvertToUrl(vWindowName)) _ + Or (Len(.WindowName) > 0 And .WindowName = vWindowName) _ + Or (Len(.WindowTitle) > 0 And .WindowTitle = vWindowName) Then + bFound = True + Exit Do + End If + End With + Loop + Else + bFound = True + vWindow = oUi._IdentifyWindow(StarDesktop.CurrentComponent) + End If + Case ScriptForge.V_OBJECT ' com.sun.star.lang.XComponent + bFound = True + vWindow = oUi._IdentifyWindow(vWindowName) + End Select + + If bFound And Not IsNull(vWindow.Frame) And Len(vWindow.DocumentType) > 0 Then + ' Create the right subclass and associate to it a new instance of the superclass + Select Case vWindow.DocumentType + Case "Base" + Set oDocument = New SF_Base + Set oSuperDocument = New SF_Document + Set oDocument.[_Super] = oSuperDocument ' Now both super and subclass are twinned + Set oSuperDocument.[_SubClass] = oDocument + Case "Calc" + Set oDocument = New SF_Calc + Set oSuperDocument = New SF_Document + Set oDocument.[_Super] = oSuperDocument ' Now both super and subclass are twinned + Set oSuperDocument.[_SubClass] = oDocument + Case "Writer" + Set oDocument = New SF_Writer + Set oSuperDocument = New SF_Document + Set oDocument.[_Super] = oSuperDocument ' Now both super and subclass are twinned + Set oSuperDocument.[_SubClass] = oDocument + Case Else ' Only superclass + Set oDocument = New SF_Document + Set oSuperDocument = oDocument + End Select + With oDocument ' Initialize attributes of subclass + Set .[Me] = oDocument + Set ._Component = vWindow.Component + ' Initialize specific attributes + Select Case vWindow.DocumentType + Case "Base" + Set ._DataSource = ._Component.DataSource + Case Else + End Select + End With + With oSuperDocument ' Initialize attributes of superclass + Set .[Me] = oSuperDocument + Set ._Component = vWindow.Component + Set ._Frame = vWindow.Frame + ._WindowName = vWindow.WindowName + ._WindowTitle = vWindow.WindowTitle + ._WindowFileName = vWindow.WindowFileName + ._DocumentType = vWindow.DocumentType + End With + End If + +Finally: + Set _NewDocument = oDocument + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Register._NewDocument + +REM ----------------------------------------------------------------------------- +Public Function _NewForm(ByRef poForm As Object _ + , Optional pbForceInit As Boolean _ + ) As Object +''' Returns an existing or a new SF_Form instance based on the argument +''' If the instance is new (not found in cache), the minimal members are initialized +''' Args: +''' poForm: com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm +''' pbForceInit: when True, initialize the form instance. Default = False +''' Returns: +''' A SF_Form instance + +Dim oForm As Object ' Return value + +Try: + Set oForm = SF_Register._FindFormInCache(poForm) + If IsNull(oForm) Then ' Not found + If IsMissing(pbForceInit) Or IsEmpty(pbForceInit) Then pbForceInit = False + Set oForm = New SF_Form + With oForm + ._Name = poForm.Name + Set .[Me] = oForm + Set ._Form = poForm + If pbForceInit Then ._Initialize() + End With + End If + +Finally: + Set _NewForm = oForm + Exit Function +End Function ' SFDocuments.SF_Register._NewForm + +REM ----------------------------------------------------------------------------- +Public Function _RegisterEventScript(poObject As Object _ + , ByVal psEvent As String _ + , ByVal psListener As String _ + , ByVal psScriptCode As String _ + , ByVal psName As String _ + ) As Boolean +''' Register a script event (psEvent) to poObject (Form, SubForm or Control) +''' Args: +''' poObject: a com.sun.star.form.XForm or XControl object +''' psEvent: the "On..." name of the event +''' psListener: the listener name corresponding with the event +''' psScriptCode: The script to trigger when psEvent occurs +''' See Scripting Framework URI Specification : https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' psName: the name of the object to associate with the event +''' Returns: +''' True when successful + +Dim oEvent As Object ' com.sun.star.script.ScriptEventDescriptor +Dim sEvent As String ' The targeted event name +Dim oParent As Object ' The parent object +Dim lIndex As Long ' The index of the targeted event in the events list of the parent object +Dim sName As String ' The corrected UNO event name +Dim i As Long + + _RegisterEventScript = False + On Local Error GoTo Catch + If Not ScriptForge.SF_Session.HasUnoMethod(poObject, "getParent") Then GoTo Finally + +Try: + ' Find object's internal index i.e. how to reach it via getByIndex() + Set oParent = poObject.getParent() + lIndex = -1 + For i = 0 To oParent.getCount() - 1 + sName = oParent.getByIndex(i).Name + If (sName = psName) Then + lIndex = i + Exit For + End If + Next i + If lIndex < 0 Then GoTo Finally ' Not found, should not happen + + ' Fix historical typo error + sEvent = Replace(LCase(Mid(psEvent, 3, 1)) & Mid(psEvent, 4), "errorOccurred", "errorOccured") + ' Apply new script code. Erasing it is done with a specific UNO method + If psScriptCode = "" Then + oParent.revokeScriptEvent(lIndex, psListener, sEvent, "") + Else + Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor") + With oEvent + .ListenerType = psListener + .EventMethod = sEvent + .ScriptType = "Script" ' Better than "Basic" + .ScriptCode = psScriptCode + End With + oParent.registerScriptEvent(lIndex, oEvent) + End If + _RegisterEventScript = True + +Finally: + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Register._RegisterEventScript + +REM ============================================== END OF SFDOCUMENTS.SF_REGISTER + \ No newline at end of file diff --git a/wizards/source/sfdocuments/SF_Writer.xba b/wizards/source/sfdocuments/SF_Writer.xba new file mode 100644 index 000000000..eded35de9 --- /dev/null +++ b/wizards/source/sfdocuments/SF_Writer.xba @@ -0,0 +1,635 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Writer +''' ========= +''' +''' The SFDocuments library gathers a number of methods and properties making easy +''' managing and manipulating LibreOffice documents +''' +''' Some methods are generic for all types of documents: they are combined in the SF_Document module. +''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Writer, SF_Base, ... +''' +''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary +''' Each subclass MUST implement also the generic methods and properties, even if they only call +''' the parent methods and properties. +''' They should also duplicate some generic private members as a subset of their own set of members +''' +''' The SF_Writer module is focused on : +''' TBD +''' +''' The current module is closely related to the "UI" service of the ScriptForge library +''' +''' Service invocation examples: +''' 1) From the UI service +''' Dim ui As Object, oDoc As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.CreateDocument("Writer", ...) +''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.odt") +''' 2) Directly if the document is already opened +''' Dim oDoc As Object +''' Set oDoc = CreateScriptService("SFDocuments.Writer", "Untitled 1") ' Default = ActiveWindow +''' ' or Set oDoc = CreateScriptService("SFDocuments.Writer", "Untitled 1") ' Untitled 1 is presumed a Writer document +''' ' The substring "SFDocuments." in the service name is optional +''' +''' Definitions: +''' TBD +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/SF_Writer.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const WRITERFORMNOTFOUNDERROR = "WRITERFORMNOTFOUNDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private [_Super] As Object ' Document superclass, which the current instance is a subclass of +Private ObjectType As String ' Must be WRITER +Private ServiceName As String + +' Window component +Private _Component As Object ' com.sun.star.lang.XComponent + +REM ============================================================ MODULE CONSTANTS + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + Set [_Super] = Nothing + ObjectType = "WRITER" + ServiceName = "SFDocuments.Writer" + Set _Component = Nothing +End Sub ' SFDocuments.SF_Writer Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDocuments.SF_Writer Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDocuments.SF_Writer Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function Forms(Optional ByVal Form As Variant) As Variant +''' Return either +''' - the list of the Forms contained in the form document +''' - a SFDocuments.Form object based on its name or its index +''' Args: +''' Form: a form stored in the document given by its name or its index +''' When absent, the list of available forms is returned +''' To get the first (unique ?) form stored in the form document, set Form = 0 +''' Exceptions: +''' WRITERFORMNOTFOUNDERROR Form not found +''' Returns: +''' A zero-based array of strings if Form is absent +''' An instance of the SF_Form class if Form exists +''' Example: +''' Dim myForm As Object, myList As Variant +''' myList = oDoc.Forms() +''' Set myForm = oDoc.Forms("myForm") + +Dim oForm As Object ' The new Form class instance +Dim oMainForm As Object ' com.sun.star.comp.sdb.Content +Dim oXForm As Object ' com.sun.star.form.XForm +Dim vFormNames As Variant ' Array of form names +Dim oForms As Object ' Forms collection +Const cstDrawPage = 0 ' Only 1 drawpage in a Writer document + +Const cstThisSub = "SFDocuments.Writer.Forms" +Const cstSubArgs = "[Form=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Form) Or IsEmpty(Form) Then Form = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + End If + +Try: + ' Start from the document component and go down to forms + Set oForms = _Component.DrawPages(cstDrawPage).Forms + vFormNames = oForms.getElementNames() + + If Len(Form) = 0 Then ' Return the list of valid form names + Forms = vFormNames + Else + If VarType(Form) = V_STRING Then ' Find the form by name + If Not ScriptForge.SF_Array.Contains(vFormNames, Form, CaseSensitive := True) Then GoTo CatchNotFound + Set oXForm = oForms.getByName(Form) + Else ' Find the form by index + If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound + Set oXForm = oForms.getByIndex(Form) + End If + ' Create the new Form class instance + Set oForm = SF_Register._NewForm(oXForm) + With oForm + Set .[_Parent] = [Me] + ._FormType = ISDOCFORM + Set ._Component = _Component + ._Initialize() + End With + Set Forms = oForm + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchNotFound: + ScriptForge.SF_Exception.RaiseFatal(WRITERFORMNOTFOUNDERROR, Form, _FileIdent()) +End Function ' SFDocuments.SF_Writer.Forms + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant _ + , Optional ObjectName As Variant _ + ) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' ObjectName: a sheet or range name +''' Returns: +''' The actual value of the property +''' Exceptions: +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDocuments.Writer.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If IsMissing(ObjectName) Or IsEmpty(ObjectName) Then ObjectName = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(ObjectName, "ObjectName", V_STRING) Then GoTo Catch + End If + +Try: + ' Superclass or subclass property ? + If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then + GetProperty = [_Super].GetProperty(PropertyName) + ElseIf Len(ObjectName) = 0 Then + GetProperty = _PropertyGet(PropertyName) + Else + GetProperty = _PropertyGet(PropertyName, ObjectName) + End If + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Writer.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Writer service as an array + + Methods = Array( _ + "Forms" _ + , "PrintOut" _ + ) + +End Function ' SFDocuments.SF_Writer.Methods + +REM ----------------------------------------------------------------------------- +Public Function PrintOut(Optional ByVal Pages As Variant _ + , Optional ByVal Copies As Variant _ + , Optional ByVal PrintBackground As Variant _ + , Optional ByVal PrintBlankPages As Variant _ + , Optional ByVal PrintEvenPages As Variant _ + , Optional ByVal PrintOddPages As Variant _ + , Optional ByVal PrintImages As Variant _ + ) As Boolean +''' Send the content of the document to the printer. +''' The printer might be defined previously by default, by the user or by the SetPrinter() method +''' Args: +''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages +''' Copies: the number of copies +''' PrintBackground: print the background image when True (default) +''' PrintBlankPages: when False (default), omit empty pages +''' PrintEvenPages: print the left pages when True (default) +''' PrintOddPages: print the right pages when True (default) +''' PrintImages: print the graphic objects when True (default) +''' Returns: +''' True when successful +''' Examples: +''' oDoc.PrintOut("1-4;10;15-18", Copies := 2, PrintImages := False) + +Dim bPrint As Boolean ' Return value +Dim vPrintOptions As Variant ' com.sun.star.text.DocumentSettings + +Const cstThisSub = "SFDocuments.Writer.PrintOut" +Const cstSubArgs = "[Pages=""""], [Copies=1], [PrintBackground=True], [PrintBlankPages=False], [PrintEvenPages=True]" _ + & ", [PrintOddPages=True], [PrintImages=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bPrint = False + +Check: + If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" + If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 + If IsMissing(PrintBackground) Or IsEmpty(PrintBackground) Then PrintBackground = True + If IsMissing(PrintBlankPages) Or IsEmpty(PrintBlankPages) Then PrintBlankPages = False + If IsMissing(PrintEvenPages) Or IsEmpty(PrintEvenPages) Then PrintEvenPages = True + If IsMissing(PrintOddPages) Or IsEmpty(PrintOddPages) Then PrintOddPages = True + If IsMissing(PrintImages) Or IsEmpty(PrintImages) Then PrintImages = True + + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not _IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintBackground, "PrintBackground", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintBlankPages, "PrintBlankPages", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintEvenPages, "PrintEvenPages", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintOddPages, "PrintOddPages", ScriptForge.V_BOOLEAN) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(PrintImages, "PrintImages", ScriptForge.V_BOOLEAN) Then GoTo Finally + End If + +Try: + vPrintOptions = _Component.createInstance("com.sun.star.text.DocumentSettings") + With vPrintOptions + .PrintPageBackground = PrintBackground + .PrintEmptyPages = PrintBlankPages + .PrintLeftPages = PrintEvenPages + .PrintRightPages = PrintOddPages + .PrintGraphics = PrintImages + .PrintDrawings = PrintImages + End With + + bPrint = [_Super].PrintOut(Pages, Copies, _Component) + +Finally: + PrintOut = bPrint + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Writer.PrintOut + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Writer class as an array + + Properties = Array( _ + "CustomProperties" _ + , "Description" _ + , "DocumentProperties" _ + , "DocumentType" _ + , "ExportFilters" _ + , "ImportFilters" _ + , "IsBase" _ + , "IsCalc" _ + , "IsDraw" _ + , "IsImpress" _ + , "IsMath" _ + , "IsWriter" _ + , "Keywords" _ + , "Readonly" _ + , "Subject" _ + , "Title" _ + , "XComponent" _ + ) + +End Function ' SFDocuments.SF_Writer.Properties + +REM ----------------------------------------------------------------------------- +Private Function SetProperty(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDocuments.Writer.set" & psProperty + If IsMissing(pvValue) Then pvValue = Empty + 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("CustomProperties") + CustomProperties = pvValue + Case UCase("Description") + Description = pvValue + Case UCase("Keywords") + Keywords = pvValue + Case UCase("Subject") + Subject = pvValue + Case UCase("Title") + Title = pvValue + Case Else + bSet = False + End Select + +Finally: + SetProperty = bSet + 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDocuments.SF_Writer.SetProperty + +REM ======================================================= SUPERCLASS PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get CustomProperties() As Variant + CustomProperties = [_Super].GetProperty("CustomProperties") +End Property ' SFDocuments.SF_Writer.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) + [_Super].CustomProperties = pvCustomProperties +End Property ' SFDocuments.SF_Writer.CustomProperties + +REM ----------------------------------------------------------------------------- +Property Get Description() As Variant + Description = [_Super].GetProperty("Description") +End Property ' SFDocuments.SF_Writer.Description + +REM ----------------------------------------------------------------------------- +Property Let Description(Optional ByVal pvDescription As Variant) + [_Super].Description = pvDescription +End Property ' SFDocuments.SF_Writer.Description + +REM ----------------------------------------------------------------------------- +Property Get DocumentProperties() As Variant + DocumentProperties = [_Super].GetProperty("DocumentProperties") +End Property ' SFDocuments.SF_Writer.DocumentProperties + +REM ----------------------------------------------------------------------------- +Property Get DocumentType() As String + DocumentType = [_Super].GetProperty("DocumentType") +End Property ' SFDocuments.SF_Writer.DocumentType + +REM ----------------------------------------------------------------------------- +Property Get ExportFilters() As Variant + ExportFilters = [_Super].GetProperty("ExportFilters") +End Property ' SFDocuments.SF_Writer.ExportFilters + +REM ----------------------------------------------------------------------------- +Property Get ImportFilters() As Variant + ImportFilters = [_Super].GetProperty("ImportFilters") +End Property ' SFDocuments.SF_Writer.ImportFilters + +REM ----------------------------------------------------------------------------- +Property Get IsBase() As Boolean + IsBase = [_Super].GetProperty("IsBase") +End Property ' SFDocuments.SF_Writer.IsBase + +REM ----------------------------------------------------------------------------- +Property Get IsCalc() As Boolean + IsCalc = [_Super].GetProperty("IsCalc") +End Property ' SFDocuments.SF_Writer.IsCalc + +REM ----------------------------------------------------------------------------- +Property Get IsDraw() As Boolean + IsDraw = [_Super].GetProperty("IsDraw") +End Property ' SFDocuments.SF_Writer.IsDraw + +REM ----------------------------------------------------------------------------- +Property Get IsImpress() As Boolean + IsImpress = [_Super].GetProperty("IsImpress") +End Property ' SFDocuments.SF_Writer.IsImpress + +REM ----------------------------------------------------------------------------- +Property Get IsMath() As Boolean + IsMath = [_Super].GetProperty("IsMath") +End Property ' SFDocuments.SF_Writer.IsMath + +REM ----------------------------------------------------------------------------- +Property Get IsWriter() As Boolean + IsWriter = [_Super].GetProperty("IsWriter") +End Property ' SFDocuments.SF_Writer.IsWriter + +REM ----------------------------------------------------------------------------- +Property Get Keywords() As Variant + Keywords = [_Super].GetProperty("Keywords") +End Property ' SFDocuments.SF_Writer.Keywords + +REM ----------------------------------------------------------------------------- +Property Let Keywords(Optional ByVal pvKeywords As Variant) + [_Super].Keywords = pvKeywords +End Property ' SFDocuments.SF_Writer.Keywords + +REM ----------------------------------------------------------------------------- +Property Get Readonly() As Variant + Readonly = [_Super].GetProperty("Readonly") +End Property ' SFDocuments.SF_Writer.Readonly + +REM ----------------------------------------------------------------------------- +Property Get Subject() As Variant + Subject = [_Super].GetProperty("Subject") +End Property ' SFDocuments.SF_Writer.Subject + +REM ----------------------------------------------------------------------------- +Property Let Subject(Optional ByVal pvSubject As Variant) + [_Super].Subject = pvSubject +End Property ' SFDocuments.SF_Writer.Subject + +REM ----------------------------------------------------------------------------- +Property Get Title() As Variant + Title = [_Super].GetProperty("Title") +End Property ' SFDocuments.SF_Writer.Title + +REM ----------------------------------------------------------------------------- +Property Let Title(Optional ByVal pvTitle As Variant) + [_Super].Title = pvTitle +End Property ' SFDocuments.SF_Writer.Title + +REM ----------------------------------------------------------------------------- +Property Get XComponent() As Variant + XComponent = [_Super].GetProperty("XComponent") +End Property ' SFDocuments.SF_Writer.XComponent + +REM ========================================================== SUPERCLASS METHODS + +REM ----------------------------------------------------------------------------- +Public Function Activate() As Boolean + Activate = [_Super].Activate() +End Function ' SFDocuments.SF_Writer.Activate + +REM ----------------------------------------------------------------------------- +Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean + CloseDocument = [_Super].CloseDocument(SaveAsk) +End Function ' SFDocuments.SF_Writer.CloseDocument + +REM ----------------------------------------------------------------------------- +Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ + , Optional ByVal Before As Variant _ + , Optional ByVal SubmenuChar As Variant _ + ) As Object + Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) +End Function ' SFDocuments.SF_Writer.CreateMenu + +REM ----------------------------------------------------------------------------- +Public Function ExportAsPDF(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Pages As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal Watermark As Variant _ + ) As Boolean + ExportAsPDF = [_Super].ExportAsPDF(FileName, Overwrite, Pages, Password, Watermark) +End Function ' SFDocuments.SF_Writer.ExportAsPDF + +REM ----------------------------------------------------------------------------- +Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean + RemoveMenu = [_Super].RemoveMenu(MenuHeader) +End Function ' SFDocuments.SF_Writer.RemoveMenu + +REM ----------------------------------------------------------------------------- +Public Sub RunCommand(Optional ByVal Command As Variant _ + , ParamArray Args As Variant _ + ) + [_Super].RunCommand(Command, Args) +End Sub ' SFDocuments.SF_Writer.RunCommand + +REM ----------------------------------------------------------------------------- +Public Function Save() As Boolean + Save = [_Super].Save() +End Function ' SFDocuments.SF_Writer.Save + +REM ----------------------------------------------------------------------------- +Public Function SaveAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Writer.SaveAs + +REM ----------------------------------------------------------------------------- +Public Function SaveCopyAs(Optional ByVal FileName As Variant _ + , Optional ByVal Overwrite As Variant _ + , Optional ByVal Password As Variant _ + , Optional ByVal FilterName As Variant _ + , Optional ByVal FilterOptions As Variant _ + ) As Boolean + SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) +End Function ' SFDocuments.SF_Writer.SaveCopyAs + +REM ----------------------------------------------------------------------------- +Public Function SetPrinter(Optional ByVal Printer As Variant _ + , Optional ByVal Orientation As Variant _ + , Optional ByVal PaperFormat As Variant _ + ) As Boolean + SetPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat) +End Function ' SFDocuments.SF_Writer.SetPrinter + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FileIdent() As String +''' Returns a file identification from the information that is currently available +''' Useful e.g. for display in error messages + + _FileIdent = [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Writer._FileIdent + +REM ----------------------------------------------------------------------------- +Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ + , Optional ByVal pbError As Boolean _ + ) As Boolean +''' Returns True if the document has not been closed manually or incidentally since the last use +''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) +''' Args: +''' pbForUpdate: if True (default = False), check additionally if document is open for editing +''' pbError: if True (default), raise a fatal error + +Dim bAlive As Boolean ' Return value + + If IsMissing(pbForUpdate) Then pbForUpdate = False + If IsMissing(pbError) Then pbError = True + +Try: + bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) + +Finally: + _IsStillAlive = bAlive + Exit Function +End Function ' SFDocuments.SF_Writer._IsStillAlive + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvArg As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Const cstSubArgs = "" + + _PropertyGet = False + + cstThisSub = "SFDocuments.Writer.get" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not _IsStillAlive() Then GoTo Finally + + Select Case psProperty + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFDocuments.SF_Writer._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Writer instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DOCUMENT]: Type/File" + + _Repr = "[Writer]: " & [_Super]._FileIdent() + +End Function ' SFDocuments.SF_Writer._Repr + +REM ============================================ END OF SFDOCUMENTS.SF_WRITER + \ No newline at end of file diff --git a/wizards/source/sfdocuments/__License.xba b/wizards/source/sfdocuments/__License.xba new file mode 100644 index 000000000..47cca670f --- /dev/null +++ b/wizards/source/sfdocuments/__License.xba @@ -0,0 +1,26 @@ + + + +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDocuments library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/sfdocuments/dialog.xlb b/wizards/source/sfdocuments/dialog.xlb new file mode 100644 index 000000000..62e84ea5c --- /dev/null +++ b/wizards/source/sfdocuments/dialog.xlb @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/wizards/source/sfdocuments/script.xlb b/wizards/source/sfdocuments/script.xlb new file mode 100644 index 000000000..ff4495124 --- /dev/null +++ b/wizards/source/sfdocuments/script.xlb @@ -0,0 +1,14 @@ + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/sfunittests/SF_Register.xba b/wizards/source/sfunittests/SF_Register.xba new file mode 100644 index 000000000..360abba50 --- /dev/null +++ b/wizards/source/sfunittests/SF_Register.xba @@ -0,0 +1,202 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFUnitTests library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNITTESTLIBRARYERROR = "UNITTESTLIBRARYERROR" + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("UnitTest", "SFUnitTests.SF_Register._NewUnitTest") ' Reference to the function initializing the service + End With + +End Sub ' SFUnitTests.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _NewUnitTest(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_UnitTest class +' Args: +''' Location: if empty, the location of the library is presumed to be in GlobalScope.BasicLibraries +''' Alternatives are: +''' - the name of a document: see SF_UI.WindowName +''' - an explicit SFDocuments.Document instance +''' - the component containing the library, typically ThisComponent +''' LibraryName: the name of the library containing the test code +''' Returns: +''' The instance or Nothing +''' Exceptions: +''' UNITTESTLIBRARYNOTFOUND The library could not be found + +Dim oUnitTest As Object ' Return value +Dim vLocation As Variant ' Alias of pvArgs(0) +Dim vLibraryName As Variant ' alias of pvArgs(1) +Dim vLocations As Variant ' "user", "share" or document +Dim sLocation As String ' A single location +Dim sTargetLocation As String ' "user" or the document name +Dim vLanguages As Variant ' "Basic", "Python", ... programming languages +Dim sLanguage As String ' A single programming language +Dim vLibraries As Variant ' Library names +Dim sLibrary As String ' A single library +Dim vModules As Variant ' Module names +Dim sModule As String ' A single module +Dim vModuleNames As Variant ' Module names +Dim oRoot As Object ' com.sun.star.script.browse.BrowseNodeFactory +Dim iLibrary As Integer ' The index of the target location in vLibraries + +Dim FSO As Object ' SF_FileSystem +Dim i As Integer, j As Integer, k As Integer, l As Integer + +Const cstService = "SFUnitTests.UnitTest" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vLocation = pvArgs(0) Else vLocation = "" + If IsEmpty(vLocation) Then vLocation = "" + If UBound(pvArgs) >= 1 Then vLibraryName = pvArgs(1) Else vLibraryName = "" + If IsEmpty(vLibraryName) Then vLibraryName = "" + If Not ScriptForge.SF_Utils._Validate(vLocation, "Location", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vLibraryName, "LibraryName", V_STRING) Then GoTo Finally + + Set oUnitTest = Nothing + Set FSO = CreateScriptService("ScriptForge.FileSystem") + + ' Determine the library container hosting the test code + + ' Browsing starts from root element + Set oRoot = SF_Utils._GetUNOService("BrowseNodeFactory").createView(com.sun.star.script.browse.BrowseNodeFactoryViewTypes.MACROORGANIZER) + + If Len(vLibraryName) > 0 Then + + ' Determine the target location, as a string. The location is either: + ' - the last component of a document's file name + ' - "user" = My Macros & Dialogs + If VarType(vLocation) = ScriptForge.V_OBJECT Then + sTargetLocation = FSO.GetName(vLocation.URL) + ElseIf Len(vLocation) = 0 Then + sTargetLocation = "user" ' Testing code is presumed NOT in "share" + Else + sTargetLocation = FSO.GetName(vLocation) + End If + + ' Exploration is done via tree nodes + iLibrary = -1 + If Not IsNull(oRoot) Then + If oRoot.hasChildNodes() Then + vLocations = oRoot.getChildNodes() + For i = 0 To UBound(vLocations) + sLocation = vLocations(i).getName() + If sLocation = sTargetLocation Then + If vLocations(i).hasChildNodes() Then + vLanguages = vLocations(i).getChildNodes() + For j = 0 To UBound(vLanguages) + sLanguage = vLanguages(j).getName() + ' Consider Basic libraries only + If sLanguage = "Basic" Then + If vLanguages(j).hasChildNodes() Then + vLibraries = vLanguages(j).getChildNodes() + For k = 0 To UBound(vLibraries) + sLibrary = vLibraries(k).getName() + ' Consider the targeted library only + If sLibrary = vLibraryName Then + iLibrary = k + If vLibraries(k).hasChildNodes() Then + vModules = vLibraries(k).getChildNodes() + vModuleNames = Array() + For l = 0 To UBound(vModules) + sModule = vModules(l).getName() + vModuleNames = ScriptForge.SF_Array.Append(vModuleNames, sModule) + Next l + End If + Exit For + End If + Next k + End If + End If + If iLibrary >= 0 Then Exit For + Next j + End If + End If + If iLibrary >= 0 Then Exit For + Next i + End If + End If + If iLibrary < 0 Then GoTo CatchLibrary + + End If + +Try: + ' Create the unittest Basic object and initialize its attributes + Set oUnitTest = New SF_UnitTest + With oUnitTest + Set .[Me] = oUnitTest + If Len(vLibraryName) > 0 Then + .LibrariesContainer = sTargetLocation + .Scope = Iif(sTargetLocation = "user", "application", "document") + .Libraries = vLibraries + .LibraryName = sLibrary + .LibraryIndex = iLibrary + .Modules = vModules + .ModuleNames = vModuleNames + ._ExecutionMode = .FULLMODE + ._WhenAssertionFails = .FAILSTOPSUITE + ' Launch the test timer + .TestTimer = CreateScriptService("ScriptForge.Timer", True) + Else + ._ExecutionMode = .SIMPLEMODE + ._WhenAssertionFails = .FAILIMMEDIATESTOP + End If + End With + +Finally: + Set _NewUnitTest = oUnitTest + Exit Function +Catch: + GoTo Finally +CatchLibrary: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTLIBRARYERROR, vLibraryName) + GoTo Finally +End Function ' SFUnitTests.SF_Register._NewUnitTest + +REM ============================================== END OF SFUNITTESTS.SF_REGISTER + \ No newline at end of file diff --git a/wizards/source/sfunittests/SF_UnitTest.xba b/wizards/source/sfunittests/SF_UnitTest.xba new file mode 100644 index 000000000..5007fb6a7 --- /dev/null +++ b/wizards/source/sfunittests/SF_UnitTest.xba @@ -0,0 +1,1818 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_UnitTest +''' =========== +''' Class providing a framework to execute and check sets of unit tests. +''' +''' The UnitTest unit testing framework was originally inspired by unittest.py in Python +''' and has a similar flavor as major unit testing frameworks in other languages. +''' +''' It supports test automation, sharing of setup and shutdown code for tests, +''' aggregation of tests into collections. +''' +''' Both the +''' - code describing the unit tests +''' - code to be tested +''' must be written exclusively in Basic (the code might call functions written in other languages). +''' Even if either code may be contained in the same module, a much better practice is to +''' store them in separate libraries. +''' Typically: +''' - in a same document when the code to be tested is contained in that document +''' - either in a "test" document or in a "My Macros" library when the code +''' to be tested is a shared library (My Macros or LibreOffice Macros). +''' The code to be tested may be released as an extension. It does not need to make +''' use of ScriptForge services in any way. +''' +''' The test reporting device is the Console. Read about the console in the ScriptForge.Exception service. +''' +''' Definitions: +''' - Test Case +''' A test case is the individual unit of testing. +''' It checks for a specific response to a particular set of inputs. +''' A test case in the UnitTest service is represented by a Basic Sub. +''' The name of the Sub starts conventionally with "Test_". +''' The test fails if one of the included AssertXXX methods returns False +''' - Test Suite +''' A test suite is a collection of test cases that should be executed together. +''' A test suite is represented by a Basic module. +''' A suite may include the tasks needed to prepare one or more tests, and any associated cleanup actions. +''' This may involve, for example, creating temporary files or directories, opening a document, loading libraries. +''' Conventionally those tasks are part pf the SetUp') and TearDown() methods. +''' - Unit test +''' A full unit test is a set of test suites (each suite in a separate Basic module), +''' each of them being a set of test cases (each case is located in a separate Basic Sub). +''' +''' Two modes: +''' Beside the normal mode ("full mode"), using test suites and test cases, a second mode exists, called "simple mode" +''' limited to the use exclusively of the Assert...() methods. +''' Their boolean returned value may support the execution of limited unit tests. +''' +''' Service invocation examples: +''' In full mode, the service creation is external to test cases +''' Dim myUnitTest As Variant +''' myUnitTest = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' ' Test code is in the library "Tests" located in the current document +''' In simple mode, the service creation is internal to every test case +''' Dim myUnitTest As Variant +''' myUnitTest = CreateScriptService("UnitTest") +''' With myUnitTest +''' If Not .AssertTrue(...) Then ... ' Only calls to the Assert...() methods are allowed +''' ' ... +''' .Dispose() +''' End With +''' +''' Minimalist full mode example +''' Code to be tested (stored in library "Standard" of document "MyDoc.ods") : +''' Function ArraySize(arr As Variant) As Long +''' If IsArray(arr) Then ArraySize = UBound(arr) - LBound(arr) + 1 Else ArraySize = -1 +''' End Function +''' Test code (stored in module "AllTests" of library "Tests" of document "MyDoc.ods") : +''' Sub Main() ' Sub to trigger manually, f.i. from the Tools + Run Macro tabbed bar +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) +''' test.Dispose() +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub Setup(test) ' The unittest service is passed as argument +''' ' Optional Sub to initialize processing of the actual test suite +''' Dim exc : exc = CreateScriptService("Exception") +''' exc.Console(Modal := False) ' Watch test progress in the console +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub Test_ArraySize(test) +''' On Local Error GoTo CatchErr +''' test.AssertEqual(ArraySize(10), -1, "When not array") +''' test.AssertEqual(ArraySize(Array(1, 2, 3)), 3, "When simple array") +''' test.AssertEqual(ArraySize(DimArray(3)), 4, "When array with empty items") +''' Exit Sub +''' CatchErr: +''' test.ReportError("ArraySize() is corrupt") +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub TearDown(test) +''' ' Optional Sub to finalize processing of the actual test suite +''' End Sub +''' +''' Error handling +''' To support the debugging of the tested code, the UnitTest service, in cases of +''' - assertion failure +''' - Basic run-time error in the tested code +''' - Basic run-time error in the testing code (the unit tests) +''' will comment the error location and description in a message box and in the console log, +''' providing every test case (in either mode) implements an error handler containing at least: +''' Sub Test_Case1(test As Variant) +''' On Local Error GoTo Catch +''' ' ... (AssertXXX(), Fail(), ...) +''' Exit Sub +''' Catch: +''' test.ReportError() +''' End Sub +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_unittest.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNITTESTMETHODERROR = "UNITTESTMETHODERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "UNITTEST" +Private ServiceName As String + +' Testing code +Private LibrariesContainer As String ' Document or user Basic library containing the test library +Private Scope As String ' Scope when running a Basic script with Session.ExecuteBasicScript() +Private Libraries As Variant ' Set of libraries +Private LibraryName As String ' Name of the library containing the test code +Private LibraryIndex As Integer ' Index in Libraries +Private Modules As Variant ' Set of modules +Private ModuleNames As Variant ' Set of module names +Private MethodNames As Variant ' Set of methods in a given module + +' Internals +Private _Verbose As Boolean ' When True, every assertion is reported,failing or not +Private _LongMessage As Boolean ' When False, only the message provided by the tester is considered + ' When True (default), that message is appended to the standard message +Private _WhenAssertionFails As Integer ' Determines what to do when a test fails + +' Test status +Private _Status As Integer ' 0 = standby + ' 1 = test suite started + ' 2 = setup started + ' 3 = test case started + ' 4 = teardown started +Private _ExecutionMode As Integer ' 1 = Test started with RunTest() + ' 2 = Test started with CreateScriptService() Only Assert() methods allowed +Private _Module As String ' Exact name of module currently running +Private _TestCase As String ' Exact name of test case currently running +Private _ReturnCode As Integer ' 0 = Normal end + ' 1 = Assertion failed + ' 2 = Skip request (in Setup() only) + '-1 = abnormal end +Private _FailedAssert As String ' Assert function that returned a failure + +' Timers +Private TestTimer As Object ' Started by CreateScriptService() +Private SuiteTimer As Object ' Started by RunTest() +Private CaseTimer As Object ' Started by new case + +' Services +Private Exception As Object ' SF_Exception +Private Session As Object ' SF_Session + +REM ============================================================ MODULE CONSTANTS + +' When assertion fails constants: error is reported + ... +Global Const FAILIGNORE = 0 ' Ignore the failure +Global Const FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in full mode) +Global Const FAILIMMEDIATESTOP = 2 ' Stop immediately (default in simple mode) + +' Unit tests status (internal use only => not Global) +Const STATUSSTANDBY = 0 ' No test active +Const STATUSSUITESTARTED = 1 ' RunTest() started +Const STATUSSETUP = 2 ' A Setup() method is running +Const STATUSTESTCASE = 3 ' A test case is running +Const STATUSTEARDOWN = 4 ' A TearDown() method is running + +' Return codes +Global Const RCNORMALEND = 0 ' Normal end of test or test not started +Global Const RCASSERTIONFAILED = 1 ' An assertion within a test case returned False +Global Const RCSKIPTEST = 2 ' A SkipTest() was issued by a Setup() method +Global Const RCABORTTEST = 3 ' Abnormal end of test + +' Execution modes +Global Const FULLMODE = 1 ' 1 = Test started with RunTest() +Global Const SIMPLEMODE = 2 ' 2 = Test started with CreateScriptService() Only Assert() methods allowed + +Const INVALIDPROCEDURECALL = "5" ' Artificial error raised when an assertion fails + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "UNITTEST" + ServiceName = "SFUnitTests.UnitTest" + LibrariesContainer = "" + Scope = "" + Libraries = Array() + LibraryName = "" + LibraryIndex = -1 + _Verbose = False + _LongMessage = True + _WhenAssertionFails = -1 + _Status = STATUSSTANDBY + _ExecutionMode = SIMPLEMODE + _Module = "" + _TestCase = "" + _ReturnCode = RCNORMALEND + _FailedAssert = "" + Set TestTimer = Nothing + Set SuiteTimer = Nothing + Set CaseTimer = Nothing + Set Exception = CreateScriptService("ScriptForge.Exception") + Set Session = CreateScriptService("ScriptForge.Session") +End Sub ' SFUnitTests.SF_UnitTest Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose() + If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose() + If Not IsNull(TestTimer) Then TestTimer = TestTimer.Dispose() + Call Class_Initialize() +End Sub ' SFUnitTests.SF_UnitTest Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFUnitTests.SF_UnitTest Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get LongMessage() As Variant +''' When False, only the message provided by the tester is considered +''' When True (default), that message is appended to the standard message + LongMessage = _PropertyGet("LongMessage") +End Property ' SFUnitTests.SF_UnitTest.LongMessage (get) + +REM ----------------------------------------------------------------------------- +Property Let LongMessage(Optional ByVal pvLongMessage As Variant) +''' Set the updatable property LongMessage + _PropertySet("LongMessage", pvLongMessage) +End Property ' SFUnitTests.SF_UnitTest.LongMessage (let) + +REM ----------------------------------------------------------------------------- +Property Get ReturnCode() As Integer +''' RCNORMALEND = 0 ' Normal end of test or test not started +''' RCASSERTIONFAILED = 1 ' An assertion within a test case returned False +''' RCSKIPTEST = 2 ' A SkipTest() was issued by a Setup() method +''' RCABORTTEST = 3 ' Abnormal end of test + ReturnCode = _PropertyGet("ReturnCode") +End Property ' SFUnitTests.SF_UnitTest.ReturnCode (get) + +REM ----------------------------------------------------------------------------- +Property Get Verbose() As Variant +''' The Verbose property indicates if all assertions (True AND False) are reported + Verbose = _PropertyGet("Verbose") +End Property ' SFUnitTests.SF_UnitTest.Verbose (get) + +REM ----------------------------------------------------------------------------- +Property Let Verbose(Optional ByVal pvVerbose As Variant) +''' Set the updatable property Verbose + _PropertySet("Verbose", pvVerbose) +End Property ' SFUnitTests.SF_UnitTest.Verbose (let) + +REM ----------------------------------------------------------------------------- +Property Get WhenAssertionFails() As Variant +''' What when an AssertXXX() method returns False +''' FAILIGNORE = 0 ' Ignore the failure +''' FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in FULL mode) +''' FAILIMMEDIATESTOP = 2 ' Stop immediately (default in SIMPLE mode) +''' In simple mode, only FAILIGNORE and FAILIMMEDIATESTOP are allowed. +''' In both modes, when WhenAssertionFails has not the value FAILIGNORE, +''' each test case MUST have a run-time error handler calling the ReportError() method. +''' Example: +''' Sub Test_sometest(Optional test) +''' On Local Error GoTo CatchError +''' ' ... one or more assert verbs +''' Exit Sub +''' CatchError: +''' test.ReportError() +''' End Sub + WhenAssertionFails = _PropertyGet("WhenAssertionFails") +End Property ' SFUnitTests.SF_UnitTest.WhenAssertionFails (get) + +REM ----------------------------------------------------------------------------- +Property Let WhenAssertionFails(Optional ByVal pvWhenAssertionFails As Variant) +''' Set the updatable property WhenAssertionFails + _PropertySet("WhenAssertionFails", pvWhenAssertionFails) +End Property ' SFUnitTests.SF_UnitTest.WhenAssertionFails (let) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AssertAlmostEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Tolerance As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are numerical values and are found close to each other. +''' It is typically used to compare very large or very small numbers. +''' Equality is confirmed when +''' - A and B can be converted to doubles +''' - The absolute difference between a and b, relative to the larger absolute value of a or b, +''' is lower or equal to the tolerance. The default tolerance is 1E-09, +''' Examples: 1E+12 and 1E+12 + 100 are almost equal +''' 1E-20 and 2E-20 are not almost equal +''' 100 and 95 are almost equal when Tolerance = 0.05 + +Dim bAssert As Boolean ' Return value +Const cstTolerance = 1E-09 +Const cstThisSub = "UnitTest.AssertAlmostEqual" +Const cstSubArgs = "A, B, [Tolerance=1E-09], [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Tolerance) Then Tolerance = cstTolerance + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Tolerance, "Tolerance", ScriptForge.V_NUMERIC) Then GoTo Catch + +Try: + bAssert = _Assert("AssertAlmostEqual", True, A, B, Message, Tolerance) + +Finally: + AssertAlmostEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertAlmostEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are found equal. +''' Equality is confirmed when +''' If A and B are scalars: +''' They should have the same VarType or both be numeric +''' Booleans and numeric values are compared with the = operator +''' Strings are compared with the StrComp() builtin function. The comparison is case-sensitive +''' Dates and times are compared up to the second +''' Null, Empty and Nothing are not equal, but AssertEqual(Nothing, Nothing) returns True +''' UNO objects are compared with the EqualUnoObjects() method +''' Basic objects are NEVER equal +''' If A and B are arrays: +''' They should have the same number of dimensions (maximum 2) +''' The lower and upper bounds must be identical for each dimension +''' Two empty arrays are equal +''' Their items must be equal one by one + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertEqual", True, A, B, Message) + +Finally: + AssertEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertFalse(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is a Boolean and its value is False + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertFalse" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertFalse", True, A, Empty, Message) + +Finally: + AssertFalse = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertFalse + +REM ----------------------------------------------------------------------------- +Public Function AssertGreater(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is greater than B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertGreater" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertGreater", True, A, B, Message) + +Finally: + AssertGreater = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertGreater + +REM ----------------------------------------------------------------------------- +Public Function AssertGreaterEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is greater than or equal to B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertGreaterEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertGreaterEqual", True, A, B, Message) + +Finally: + AssertGreaterEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertGreaterEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertIn(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A, a string, is found within B +''' B may be a 1D array, a ScriptForge dictionary or a string. +''' When B is an array, A may be a date or a numeric value. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIn" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertIn", True, A, B, Message) + +Finally: + AssertIn = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertIn + +REM ----------------------------------------------------------------------------- +Public Function AssertIsInstance(Optional ByRef A As Variant _ + , Optional ByRef ObjectType As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is an object instance of the class ObjectType or a variable of type ObjectType. +''' A may be: +''' - a ScriptForge object +''' ObjectType is a string like "DICTIONARY", "calc", "Dialog", "exception", etc. +''' - a UNO object +''' ObjectType is a string identical with values returned by the SF_Session.UnoObjectType() +''' - any variable, providing it is neither an object nor an array +''' ObjectType is a string identifying a value returned by the TypeName() builtin function +''' - an array +''' ObjectType is expected to be "array" + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIsInstance" +Const cstSubArgs = "A, ObjectType, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(ObjectType) Then ObjectType = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(ObjectType, "ObjectType", V_STRING) Then GoTo Catch + + +Try: + bAssert = _Assert("AssertIsInstance", True, A, Empty, Message, ObjectType) + +Finally: + AssertIsInstance = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertIsInstance + +REM ----------------------------------------------------------------------------- +Public Function AssertIsNothing(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is an object that has the Nothing value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIsNothing" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertIsNothing", True, A, Empty, Message) + +Finally: + AssertIsNothing = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertIsNothing + +REM ----------------------------------------------------------------------------- +Public Function AssertIsNull(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A has the Null value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIsNull" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertIsNull", True, A, Empty, Message) + +Finally: + AssertIsNull = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertIsNull + +REM ----------------------------------------------------------------------------- +Public Function AssertLess(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is less than B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertLess" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertLess", False, A, B, Message) + +Finally: + AssertLess = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertLess + +REM ----------------------------------------------------------------------------- +Public Function AssertLessEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is less than or equal to B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertLessEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertLessEqual", False, A, B, Message) + +Finally: + AssertLessEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertLessEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertLike(Optional ByRef A As Variant _ + , Optional ByRef Pattern As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True if string A matches a given pattern containing wildcards +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertLike" +Const cstSubArgs = "A, Pattern, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Pattern) Then Pattern = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Pattern, "Pattern", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertLike", True, A, Empty, Message, Pattern) + +Finally: + AssertLike = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertLike + +REM ----------------------------------------------------------------------------- +Public Function AssertNotAlmostEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Tolerance As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are numerical values and are not found close to each other. +''' Read about almost equality in the comments linked to the AssertEqual() method. + +Dim bAssert As Boolean ' Return value +Const cstTolerance = 1E-09 +Const cstThisSub = "UnitTest.AssertNotAlmostEqual" +Const cstSubArgs = "A, B, [Tolerance=1E-09], [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Tolerance) Then Tolerance = cstTolerance + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Tolerance, "Tolerance", ScriptForge.V_NUMERIC) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotAlmostEqual", False, A, B, Message, Tolerance) + +Finally: + AssertNotAlmostEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotAlmostEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertNotEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are found unequal. +''' Read about equality in the comments linked to the AssertEqual() method. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotEqual", False, A, B, Message) + +Finally: + AssertNotEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertNotIn(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A, a string, is not found within B +''' B may be a 1D array, a ScriptForge dictionary or a string. +''' When B is an array, A may be a date or a numeric value. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotIn" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotIn", False, A, B, Message) + +Finally: + AssertNotIn = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotIn + +REM ----------------------------------------------------------------------------- +Public Function AssertNotInstance(Optional ByRef A As Variant _ + , Optional ByRef ObjectType As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is an object instance of the class ObjectType or a variable of type ObjectType. +''' More details to be read under the AssertInstance() function. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotInstance" +Const cstSubArgs = "A, ObjectType, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(ObjectType) Then ObjectType = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(ObjectType, "ObjectType", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotInstance", False, A, Empty, Message, ObjectType) + +Finally: + AssertNotInstance = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotInstance + +REM ----------------------------------------------------------------------------- +Public Function AssertNotLike(Optional ByRef A As Variant _ + , Optional ByRef Pattern As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True if A is not a string or does not match a given pattern containing wildcards +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotLike" +Const cstSubArgs = "A, Pattern, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Pattern) Then Pattern = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Pattern, "Pattern", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotLike", False, A, Empty, Message, Pattern) + +Finally: + AssertNotLike = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotLike + +REM ----------------------------------------------------------------------------- +Public Function AssertNotNothing(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True except when A is an object that has the Nothing value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotNothing" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotNothing", False, A, Empty, Message) + +Finally: + AssertNotNothing = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotNothing + +REM ----------------------------------------------------------------------------- +Public Function AssertNotNull(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True except when A has the Null value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotNull" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotNull", False, A, Empty, Message) + +Finally: + AssertNotNull = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotNull + +REM ----------------------------------------------------------------------------- +Public Function AssertNotRegex(Optional ByRef A As Variant _ + , Optional ByRef Regex As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is not a string or does not match the given regular expression. +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotRegex" +Const cstSubArgs = "A, Regex, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Regex) Then Regex = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotRegex", False, A, Empty, Message, Regex) + +Finally: + AssertNotRegex = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotRegex + +REM ----------------------------------------------------------------------------- +Public Function AssertRegex(Optional ByRef A As Variant _ + , Optional ByRef Regex As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when string A matches the given regular expression. +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertRegex" +Const cstSubArgs = "A, Regex, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Regex) Then Regex = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertRegex", True, A, Empty, Message, Regex) + +Finally: + AssertRegex = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertRegex + +REM ----------------------------------------------------------------------------- +Public Function AssertTrue(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is a Boolean and its value is True + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertTrue" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertTrue", True, A, Empty, Message) + +Finally: + AssertTrue = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertTrue + +REM ----------------------------------------------------------------------------- +Public Sub Fail(Optional ByVal Message As Variant) +''' Forces a test failure + +Dim bAssert As Boolean ' Fictive return value +Const cstThisSub = "UnitTest.Fail" +Const cstSubArgs = "[Message=""""]" + +Check: + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("Fail", False, Empty, Empty, Message) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFUnitTests.SF_UnitTest.Fail + +REM ----------------------------------------------------------------------------- +Public Sub Log(Optional ByVal Message As Variant) +''' Records the given message in the test report (console) + +Dim bAssert As Boolean ' Fictive return value +Dim bVerbose As Boolean : bVerbose = _Verbose +Const cstThisSub = "UnitTest.Log" +Const cstSubArgs = "[Message=""""]" + +Check: + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + ' Force the display of the message in the console + _Verbose = True + bAssert = _Assert("Log", True, Empty, Empty, Message) + _Verbose = bVerbose + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFUnitTests.SF_UnitTest.Log + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myUnitTest.GetProperty("Duration") + +Const cstThisSub = "UnitTest.GetProperty" +Const cstSubArgs = "PropertyName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.Properties + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list or methods of the UnitTest class as an array + + Methods = Array( _ + "AssertAlmostEqual" _ + , "AssertEqual" _ + , "AssertFalse" _ + , "AssertGreater" _ + , "AssertGreaterEqual" _ + , "AssertIn" _ + , "AssertIsInstance" _ + , "AssertIsNothing" _ + , "AssertLike" _ + , "AssertNotRegex" _ + , "AssertIsNull" _ + , "AssertLess" _ + , "AssertLessEqual" _ + , "AssertNotAlmostEqual" _ + , "AssertNotEqual" _ + , "AssertNotIn" _ + , "AssertNotInstance" _ + , "AssertNotLike" _ + , "AssertNotNothing" _ + , "AssertNotNull" _ + , "AssertRegex" _ + , "AssertTrue" _ + , "Fail" _ + , "Log" _ + , "RunTest" _ + , "SkipTest" _ + ) + +End Function ' SFUnitTests.SF_UnitTest.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the UnitTest class as an array + + Properties = Array( _ + "LongMessage" _ + , "ReturnCode" _ + , "Verbose" _ + , "WhenAssertionFails" _ + ) + +End Function ' SFUnitTests.SF_UnitTest.Properties + +REM ----------------------------------------------------------------------------- +Public Sub ReportError(Optional ByVal Message As Variant) +''' DIsplay a message box with the current property values of the "Exception" service. +''' Depending on the WhenAssertionFails property, a Raise() or RaiseWarning() +''' is issued. The Raise() method stops completely the Basic running process. +''' The ReportError() method is presumed present in a user script in an error +''' handling part of the actual testcase. +''' Args: +''' Message: a string to replace or to complete the standard message description +''' Example: +''' See the Test_ArraySize() sub in the module's heading example + +Dim sLine As String ' Line number where the error occurred +Dim sError As String ' Exception description +Dim sErrorCode As String ' Exception number +Const cstThisSub = "UnitTest.ReportError" +Const cstSubArgs = "[Message=""""]" + +Check: + If IsMissing(Message) Or IsEmpty(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If VarType(Message) <> V_STRING Then Message = "" + +Try: + sLine = "ln " & CStr(Exception.Source) + If _ExecutionMode = FULLMODE Then sLine = _Module & "." & _TestCase & " " & sLine + If Len(Message) > 0 Then + sError = Message + Else + If Exception.Number = INVALIDPROCEDURECALL Then + sError = "Test case failure" + sErrorCode = "ASSERTIONFAILED" + Else + sError = Exception.Description + sErrorCode = CStr(Exception.Number) + End If + End If + + Select Case _WhenAssertionFails + Case FAILIGNORE + Case FAILSTOPSUITE + Exception.RaiseWarning(sErrorCode, sLine, sError) + Case FAILIMMEDIATESTOP + Exception.Raise(sErrorCode, sLine, sError) + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFUnitTests.SF_UnitTest.ReportError +REM ----------------------------------------------------------------------------- +Public Function RunTest(Optional ByVal TestSuite As Variant _ + , Optional ByVal TestCasePattern As Variant _ + , Optional ByVal Message As Variant _ + ) As Integer +''' Execute a test suite pointed out by a module name. +''' Each test case will be run independently from each other. +''' The names of the test cases to be run may be selected with a string pattern. +''' The test is "orchestrated" by this method: +''' 1. Execute the optional Setup() method present in the module +''' 2. Execute once each test case, in any order +''' 3, Execute the optional TearDown() method present in the module +''' Args: +''' TestSuite: the name of the module containing the set of test cases to run +''' TestCasePattern: the pattern that the test cases must match. The comparison is not case-sensitive. +''' Non-matching functions and subs are ignored. +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' The default pattern is "Test_*" +''' Message: the message to be displayed in the console when the test starts. +''' Returns: +''' One of the return codes of the execution (RCxxx constants) +''' Examples: +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) + +Dim iRun As Integer ' Return value +Dim sRunMessage As String ' Reporting +Dim iModule As Integer ' Index of module currently running +Dim vMethods As Variant ' Set of methods +Dim sMethod As String ' A single method +Dim iMethod As Integer ' Index in MethodNames +Dim m As Integer + +Const cstThisSub = "UnitTest.RunTest" +Const cstSubArgs = "TestSuite, [TestCasePattern=""Test_*""], [Message=""""]" + + iRun = RCNORMALEND + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(TestCasePattern) Or IsEmpty(TestCasePattern) Then TestCasePattern = "Test_*" + If IsMissing(Message) Or IsEmpty(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(TestSuite, "TestSuite", V_STRING, ModuleNames) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(TestCasePattern, "TestCasePattern", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Message, "Message", V_STRING) Then GoTo Catch + + ' A RunTest() is forbidden inside a test suite or when simple mode + If _Status <> STATUSSTANDBY Or _ExecutionMode <> FULLMODE Then GoTo CatchMethod + + ' Ignore any call when an abnormal end has been encountered + If _ReturnCode = RCABORTTEST Then GoTo Catch + +Try: + iModule = ScriptForge.SF_Array.IndexOf(ModuleNames, TestSuite, CaseSensitive := False, SortOrder := "ASC") + _Module = ModuleNames(iModule) + + ' Start timer + If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose() + Set SuiteTimer = CreateScriptService("ScriptForge.Timer", True) + + ' Report the start of a new test suite + sRunMessage = "RUNTEST ENTER testsuite='" & LibraryName & "." & _Module & "', pattern='" & TestCasePattern & "'" + _ReportMessage(sRunMessage, Message) + _Status = STATUSSUITESTARTED + + ' Collect all the methods of the module + If Modules(iModule).hasChildNodes() Then + vMethods = Modules(iModule).getChildNodes() + MethodNames = Array() + For m = 0 To UBound(vMethods) + sMethod = vMethods(m).getName() + MethodNames = ScriptForge.SF_Array.Append(MethodNames, sMethod) + Next m + End If + + ' Execute the Setup() method, if it exists + iMethod = ScriptForge.SF_Array.IndexOf(MethodNames, "Setup", CaseSensitive := False, SortOrder := "ASC") + If iMethod >= 0 Then + _TestCase = MethodNames(iMethod) ' _TestCase is used in ReportError() + If Not _ExecuteScript(_TestCase) Then GoTo Catch + End If + + ' Execute the test cases that match the pattern + For iMethod = 0 To UBound(MethodNames) + If _ReturnCode = RCSKIPTEST Or _ReturnCode = RCASSERTIONFAILED Then Exit For + sMethod = MethodNames(iMethod) + If ScriptForge.SF_String.IsLike(sMethod, TestCasePattern, CaseSensitive := False) Then + _TestCase = sMethod + ' Start timer + If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose() + Set CaseTimer = CreateScriptService("ScriptForge.Timer", True) + If Not _ExecuteScript(sMethod) Then GoTo Catch + CaseTimer.Terminate() + _TestCase = "" + End If + Next iMethod + + If _ReturnCode <> RCSKIPTEST Then + ' Execute the TearDown() method, if it exists + iMethod = ScriptForge.SF_Array.IndexOf(MethodNames, "TearDown", CaseSensitive := False, SortOrder := "ASC") + If iMethod >= 0 Then + _TestCase = MethodNames(iMethod) ' _TestCase is used in ReportError() + If Not _ExecuteScript(_TestCase) Then GoTo Catch + End If + End If + + ' Report the end of the current test suite + sRunMessage = "RUNTEST EXIT testsuite='" & LibraryName & "." & _Module & "' " & _Duration("Suite", True) + _ReportMessage(sRunMessage, Message) + + ' Stop timer + SuiteTimer.Terminate() + + ' Housekeeping + MethodNames = Array() + _Module = "" + _Status = STATUSSTANDBY + +Finally: + _ReturnCode = iRun + RunTest = iRun + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + iRun = RCABORTTEST + GoTo Finally +CatchMethod: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTMETHODERROR, "RunTest") + GoTo Catch +End Function ' SFUnitTests.SF_UnitTest.RunTest + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "UnitTest.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SkipTest(Optional ByVal Message As Variant) As Boolean +''' Interrupt the running test suite. The TearDown() method is NOT executed. +''' The SkipTest() method is normally meaningful only in a Setup() method when not all the +''' conditions to run the test are met. +''' It is up to the Setup() script to exit shortly after the SkipTest() call.. +''' The method may also be executed in a test case. Next test cases will not be executed. +''' Remember however that the test cases are executed is an arbitrary order. +''' Args: +''' Message: the message to be displayed in the console +''' Returns: +''' True when successful +''' Examples: +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.SkipTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) + +Dim bSkip As Boolean ' Return value +Dim sSkipMessage As String ' Reporting + +Const cstThisSub = "UnitTest.SkipTest" +Const cstSubArgs = "[Message=""""]" + + bSkip = False + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Message) Or IsEmpty(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Message, "Message", V_STRING) Then GoTo Catch + + ' A SkipTest() is forbidden when simple mode + If _ExecutionMode <> FULLMODE Then GoTo CatchMethod + + ' Ignore any call when an abnormal end has been encountered + If _ReturnCode = RCABORTTEST Then GoTo Catch + +Try: + If _Status = STATUSSETUP Or _Status = STATUSTESTCASE Then + _ReturnCode = RCSKIPTEST + bSkip = True + ' Exit message + sSkipMessage = " SKIPTEST testsuite='" & LibraryName & "." & _Module & "' " & _Duration("Suite", True) + _ReportMessage(sSkipMessage, Message) + End If + +Finally: + SkipTest = bSkip + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + _ReturnCode = RCABORTTEST + GoTo Finally +CatchMethod: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTMETHODERROR, "SkipTest") + GoTo Catch +End Function ' SFUnitTests.SF_UnitTest.SkipTest + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _Assert(ByVal psAssert As String _ + , ByVal pvReturn As Variant _ + , ByRef A As Variant _ + , ByRef B As Variant _ + , Optional ByVal pvMessage As Variant _ + , Optional ByVal pvArg As Variant _ + ) As Boolean +''' Evaluation of the assertion and management of the success or the failure +''' Args: +''' psAssert: the assertion verb as a string +''' pvReturn: may be True, False or Empty +''' When True (resp. False), the assertion must be evaluated as True (resp. False) +''' e.g. AssertEqual() will call _Assert("AssertEqual", True, ...) +''' AssertNotEqual() will call _Assert("AssertNotEqual", False, ...) +''' Empty may be used for recursive calls of the function (for comparing arrays, ...) +''' A: always present +''' B: may be empty +''' pvMessage: the message to display on the console +''' pvArg: optional additional argument of the assert function +''' Returns: +''' True when success + +Dim bAssert As Boolean ' Return value +Dim bEval As Boolean ' To be compared with pvReturn +Dim iVarTypeA As Integer ' Alias of _VarTypeExt(A) +Dim iVarTypeB As Integer ' Alias of _VarTypeExt(B) +Dim oVarTypeObjA As Object ' SF_Utils.ObjectDescriptor +Dim oVarTypeObjB As Object ' SF_Utils.ObjectDescriptor +Dim oUtils As Object : Set oUtils = ScriptForge.SF_Utils +Dim iDims As Integer ' Number of dimensions of array +Dim oAliasB As Object ' Alias of B to bypass the "Object variable not set" issue +Dim dblA As Double ' Alias of A +Dim dblB As Double ' Alias of B +Dim dblTolerance As Double ' Alias of pvArg +Dim oString As Object : Set oString = ScriptForge.SF_String +Dim sArgName As String ' Argument description +Dim i As Long, j As Long + +Check: + bAssert = False + If IsMissing(pvMessage) Then pvMessage = "" + If Not oUtils._Validate(pvMessage, "Message", V_STRING) Then GoTo Finally + If IsMissing(pvArg) Then pvArg = "" + +Try: + iVarTypeA = oUtils._VarTypeExt(A) + iVarTypeB = oUtils._VarTypeExt(B) + sArgName = "" + + Select Case UCase(psAssert) + Case UCase("AssertAlmostEqual"), UCase("AssertNotAlmostEqual") + bEval = ( iVarTypeA = iVarTypeB And iVarTypeA = ScriptForge.V_NUMERIC ) + If bEval Then + dblA = CDbl(A) + dblB = CDbl(B) + dblTolerance = Abs(CDbl(pvArg)) + bEval = ( Abs(dblA - dblB) <= (dblTolerance * Iif(Abs(dblA) > Abs(DblB), Abs(dblA), Abs(dblB))) ) + End If + Case UCase("AssertEqual"), UCase("AssertNotEqual") + If Not IsArray(A) Then + bEval = ( iVarTypeA = iVarTypeB ) + If bEval Then + Select Case iVarTypeA + Case V_EMPTY, V_NULL + Case V_STRING + bEval = ( StrComp(A, B, 1) = 0 ) + Case ScriptForge.V_NUMERIC, ScriptForge.V_BOOLEAN + bEval = ( A = B ) + Case V_DATE + bEval = ( Abs(DateDiff("s", A, B)) = 0 ) + Case ScriptForge.V_OBJECT + Set oVarTypeObjA = oUtils._VarTypeObj(A) + Set oVarTypeObjB = oUtils._VarTypeObj(B) + bEval = ( oVarTypeObjA.iVarType = oVarTypeObjB.iVarType ) + If bEval Then + Select Case oVarTypeObjA.iVarType + Case ScriptForge.V_NOTHING + Case ScriptForge.V_UNOOBJECT + bEval = EqualUnoObjects(A, B) + Case ScriptForge.V_SFOBJECT, ScriptForge.V_BASICOBJECT + bEval = False + End Select + End If + End Select + End If + Else ' Compare arrays + bEval = IsArray(B) + If bEval Then + iDims = ScriptForge.SF_Array.CountDims(A) + bEval = ( iDims = ScriptForge.SF_Array.CountDims(B) And iDims <= 2 ) + If bEval Then + Select Case iDims + Case -1, 0 ' Scalars (not possible) or empty arrays + Case 1 ' 1D array + bEval = ( LBound(A) = LBound(B) And UBound(A) = UBound(B) ) + If bEval Then + For i = LBound(A) To UBound(A) + bEval = _Assert(psAssert, Empty, A(i), B(i)) + If Not bEval Then Exit For + Next i + End If + Case 2 ' 2D array + bEval = ( LBound(A, 1) = LBound(B, 1) And UBound(A, 1) = UBound(B, 1) _ + And LBound(A, 2) = LBound(B, 2) And UBound(A, 2) = UBound(B, 2) ) + If bEval Then + For i = LBound(A, 1) To UBound(A, 1) + For j = LBound(A, 2) To UBound(A, 2) + bEval = _Assert(psAssert, Empty, A(i, j), B(i, j)) + If Not bEval Then Exit For + Next j + If Not bEval Then Exit For + Next i + End If + End Select + End If + End If + End If + Case UCase("AssertFalse") + If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = Not A Else bEval = False + Case UCase("AssertGreater"), UCase("AssertLessEqual") + bEval = ( iVarTypeA = iVarTypeB _ + And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) ) + If bEval Then bEval = ( A > B ) + Case UCase("AssertGreaterEqual"), UCase("AssertLess") + bEval = ( iVarTypeA = iVarTypeB _ + And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) ) + If bEval Then bEval = ( A >= B ) + Case UCase("AssertIn"), UCase("AssertNotIn") + Set oVarTypeObjB = oUtils._VarTypeObj(B) + Select Case True + Case iVarTypeA = V_STRING And iVarTypeB = V_STRING + bEval = ( Len(A) > 0 And Len(B) > 0 ) + If bEval Then bEval = ( InStr(1, B, A, 0) > 0 ) + Case (iVarTypeA = V_DATE Or iVarTypeA = V_STRING Or iVarTypeA = ScriptForge.V_NUMERIC) _ + And iVarTypeB >= ScriptForge.V_ARRAY + bEval = ( ScriptForge.SF_Array.CountDims(B) = 1 ) + If bEval Then bEval = ScriptForge.SF_Array.Contains(B, A, CaseSensitive := True) + Case oVarTypeObjB.iVarType = ScriptForge.V_SFOBJECT And oVarTypeObjB.sObjectType = "DICTIONARY" + bEval = ( Len(A) > 0 ) + If bEval Then + Set oAliasB = B + bEval = ScriptForge.SF_Array.Contains(oAliasB.Keys(), A, CaseSensitive := True) + End If + Case Else + bEval = False + End Select + Case UCase("AssertIsInstance"), UCase("AssertNotInstance") + Set oVarTypeObjA = oUtils._VarTypeObj(A) + sArgName = "ObjectType" + With oVarTypeObjA + Select Case .iVarType + Case ScriptForge.V_UNOOBJECT + bEval = ( pvArg = .sObjectType ) + Case ScriptForge.V_SFOBJECT + bEval = ( UCase(pvArg) = UCase(.sObjectType) Or UCase(pvArg) = "SF_" & UCase(.sObjectType) _ + Or UCase(pvArg) = UCase(.sServiceName) ) + Case ScriptForge.V_NOTHING, ScriptForge.V_BASICOBJECT + bEval = False + Case >= ScriptForge.V_ARRAY + bEval = ( UCase(pvArg) = "ARRAY" ) + Case Else + bEval = ( UCase(TypeName(A)) = UCase(pvArg) ) + End Select + End With + Case UCase("AssertIsNothing"), UCase("AssertNotNothing") + bEval = ( iVarTypeA = ScriptForge.V_OBJECT ) + If bEval Then bEval = ( A Is Nothing ) + Case UCase("AssertIsNull"), UCase("AssertNotNull") + bEval = ( iVarTypeA = V_NULL ) + Case UCase("AssertLike"), UCase("AssertNotLike") + sArgName = "Pattern" + bEval = ( iVarTypeA = V_STRING And Len(pvArg) > 0 ) + If bEval Then bEval = oString.IsLike(A, pvArg, CaseSensitive := True) + Case UCase("AssertRegex"), UCase("AssertNotRegex") + sArgName = "Regex" + bEval = ( iVarTypeA = V_STRING And Len(pvArg) > 0 ) + If bEval Then bEval = oString.IsRegex(A, pvArg, CaseSensitive := True) + Case UCase("AssertTrue") + If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = A Else bEval = False + Case UCase("FAIL"), UCase("Log") + bEval = True + Case Else + End Select + + ' Check the result of the assertion vs. what it should be + If IsEmpty(pvReturn) Then + bAssert = bEval ' Recursive call => Reporting and failure management are done by calling _Assert() procedure + Else ' pvReturn is Boolean => Call from user script + bAssert = Iif(pvReturn, bEval, Not bEval) + ' Report the assertion evaluation + If _Verbose Or Not bAssert Then + _ReportMessage(" " & psAssert _ + & Iif(IsEmpty(A), "", " = " & bAssert & ", A = " & oUtils._Repr(A)) _ + & Iif(IsEmpty(B), "", ", B = " & oUtils._Repr(B)) _ + & Iif(Len(sArgName) = 0, "", ", " & sArgName & " = " & pvArg) _ + , pvMessage) + End If + ' Manage assertion failure + If Not bAssert Then + _FailedAssert = psAssert + Select Case _WhenAssertionFails + Case FAILIGNORE ' Do nothing + Case Else + _ReturnCode = RCASSERTIONFAILED + ' Cause artificially a run-time error + Dim STRINGBADUSE As String + + '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + '+ To avoid a run-time error on next executable statement, + + '+ insert an error handler in the code of your test case: + + '+ Like in next code: + + '+ On Local Error GoTo Catch + + '+ ... + + '+ Catch: + + '+ myTest.ReportError() + + '+ Exit Sub + + '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + STRINGBADUSE = Right("", -1) ' Raises "#5 - Invalid procedure call" error + + End Select + End If + End If + +Finally: + _Assert = bAssert + Exit Function + +End Function ' SFUnitTests.SF_UnitTest._Assert + +REM ----------------------------------------------------------------------------- +Private Function _Duration(ByVal psTimer As String _ + , Optional ByVal pvBrackets As Variant _ + ) As String +''' Return the Duration property of the given timer +''' or the empty string if the timer is undefined or not started +''' Args: +''' psTimer: "Test", "Suite" or "TestCase" +''' pbBrackets: surround with brackets when True. Default = False + +Dim sDuration As String ' Return value +Dim oTimer As Object ' Alias of psTimer + +Check: + If IsMissing(pvBrackets) Or IsEmpty(pvBrackets) Then pvBrackets = False + +Try: + Select Case psTimer + Case "Test" : Set oTimer = TestTimer + Case "Suite" : Set oTimer = SuiteTimer + Case "TestCase", "Case" : Set oTimer = CaseTimer + End Select + If Not IsNull(oTimer) Then + sDuration = CStr(oTimer.Duration) & " " + If pvBrackets Then sDuration = "(" & Trim(sDuration) & " sec)" + Else + sDuration = "" + End If + +Finally: + _Duration = sDuration +End Function ' SFUnitTests.SF_UnitTest._Duration + +REM ----------------------------------------------------------------------------- +Private Function _ExecuteScript(psMethod As String) As Boolean +''' Run the given method and report start and stop +''' The targeted method is presumed not to return anything (Sub) +''' Args: +''' psMethod: the scope, the library and the module are predefined in the instance internals +''' Returns: +''' True when successful + +Dim bExecute As Boolean ' Return value +Dim sRun As String ' SETUP, TEARDOWN or TESTCASE + + On Local Error GoTo Catch + bExecute = True + +Try: + ' Set status before the effective execution + sRun = UCase(psMethod) + Select Case UCase(psMethod) + Case "SETUP" : _Status = STATUSSETUP + Case "TEARDOWN" : _Status = STATUSTEARDOWN + Case Else : _Status = STATUSTESTCASE + sRun = "TESTCASE" + End Select + + ' Report and execute + _ReportMessage(" " & sRun & " " & LibraryName & "." & _Module & "." & psMethod & "() ENTER") + Session.ExecuteBasicScript(Scope, LibraryName & "." & _Module & "." & psMethod, [Me]) + _ReportMessage(" " & sRun & " " & LibraryName & "." & _Module & "." & psMethod & "() EXIT" _ + & Iif(_STATUS = STATUSTESTCASE, " " & _Duration("Case", True), "")) + ' Reset status + _Status = STATUSSUITESTARTED + +Finally: + _ExecuteScript = bExecute + Exit Function +Catch: + bExecute = False + _ReturnCode = RCABORTTEST + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest._ExecuteScript + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) +''' Return the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Dim cstSubArgs As String + + cstThisSub = "UnitTest.get" & psProperty + cstSubArgs = "" + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case UCase(psProperty) + Case UCase("LongMessage") + _PropertyGet = _LongMessage + Case UCase("ReturnCode") + _PropertyGet = _ReturnCode + Case UCase("Verbose") + _PropertyGet = _Verbose + Case UCase("WhenAssertionFails") + _PropertyGet = _WhenAssertionFails + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Dim vWhenFailure As Variant ' WhenAssertionFails allowed values +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFUnitTests.UnitTest.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + bSet = True + Select Case UCase(psProperty) + Case UCase("LongMessage") + If Not ScriptForge.SF_Utils._Validate(pvValue, "LongMessage", ScriptForge.V_BOOLEAN) Then GoTo Finally + _LongMessage = pvValue + Case UCase("Verbose") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Verbose", ScriptForge.V_BOOLEAN) Then GoTo Finally + _Verbose = pvValue + Case UCase("WhenAssertionFails") + If _ExecutionMode = SIMPLEMODE Then vWhenFailure = Array(0, 3) Else vWhenFailure = Array(0, 1, 2, 3) + If Not ScriptForge.SF_Utils._Validate(pvValue, "WhenAssertionFails", ScriptForge.V_NUMERIC, vWhenFailure) Then GoTo Finally + _WhenAssertionFails = pvValue + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _ReportMessage(ByVal psSysMessage As String _ + , Optional ByVal pvMessage As Variant _ + ) As Boolean +''' Report in the console: +''' - either the standard message +''' - either the user message when not blank +''' - or both +''' Args: +''' psSysMessage: the standard message as built by the calling routine +''' psMessage: the message provided by the user script +''' Returns: +''' True when successful + +Dim bReport As Boolean ' Return value +Dim sIndent As String ' Indentation spaces + + bReport = False + On Local Error GoTo Catch + If IsMissing(pvMessage) Or IsEmpty(pvMessage) Then pvMessage = "" + +Try: + Select Case True + Case Len(pvMessage) = 0 + Exception.DebugPrint(psSysMessage) + Case _LongMessage + Exception.DebugPrint(psSysMessage, pvMessage) + Case Else + Select Case _Status + Case STATUSSTANDBY, STATUSSUITESTARTED : sIndent = "" + Case STATUSSUITESTARTED : sIndent = Space(2) + Case Else : sIndent = Space(4) + End Select + Exception.DebugPrint(sIndent & pvMessage) + End Select + +Finally: + _ReportMessage = bReport + Exit Function +Catch: + bReport = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest._ReportMessage + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the UnitTest instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[UnitTest] + +Const cstUnitTest = "[UnitTest]" +Const cstMaxLength = 50 ' Maximum length for items + + _Repr = cstUnitTest + +End Function ' SFUnitTests.SF_UnitTest._Repr + +REM ============================================== END OF SFUNITTESTS.SF_UNITTEST + \ No newline at end of file diff --git a/wizards/source/sfunittests/__License.xba b/wizards/source/sfunittests/__License.xba new file mode 100644 index 000000000..a8e6a7779 --- /dev/null +++ b/wizards/source/sfunittests/__License.xba @@ -0,0 +1,26 @@ + + + +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFUnitTests library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/sfunittests/dialog.xlb b/wizards/source/sfunittests/dialog.xlb new file mode 100644 index 000000000..2d4a57045 --- /dev/null +++ b/wizards/source/sfunittests/dialog.xlb @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/wizards/source/sfunittests/script.xlb b/wizards/source/sfunittests/script.xlb new file mode 100644 index 000000000..3292dc12c --- /dev/null +++ b/wizards/source/sfunittests/script.xlb @@ -0,0 +1,7 @@ + + + + + + + \ No newline at end of file diff --git a/wizards/source/sfwidgets/SF_Menu.xba b/wizards/source/sfwidgets/SF_Menu.xba new file mode 100644 index 000000000..e21168536 --- /dev/null +++ b/wizards/source/sfwidgets/SF_Menu.xba @@ -0,0 +1,590 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFWidgets library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Menu +''' ============ +''' Display a menu in the menubar of a document or a form document. +''' After use, the menu will not be saved neither in the application settings, nor in the document. +''' +''' The menu will be displayed, as usual, when its header in the menubar is clicked. +''' When one of its items is selected, there are 3 alternative options: +''' - a UNO command (like ".uno:About") is triggered +''' - a user script is run receiving a standard argument defined in this service +''' - one of above combined with a toggle of the status of the item +''' +''' The menu is described from top to bottom. Each menu item receives a numeric and a string identifier. +''' +''' Menu items are either: +''' - usual items +''' - checkboxes +''' - radio buttons +''' - a menu separator +''' Menu items can be decorated with icons and tooltips. +''' +''' Definitions: +''' SubmenuCharacter: the character or the character string that identifies how menus are cascading +''' Default = ">" +''' Can be set when invoking the Menu service +''' ShortcutCharacter: the underline access key character +''' Default = "~" +''' +''' Menus and submenus +''' To create a menu with submenus, use the character defined in the +''' SubmenuCharacter property while creating the menu entry to define where it will be +''' placed. For instance, consider the following menu/submenu hierarchy. +''' Item A +''' Item B > Item B.1 +''' Item B.2 +''' ------ (line separator) +''' Item C > Item C.1 > Item C.1.1 +''' Item C.1.2 +''' Item C > Item C.2 > Item C.2.1 +''' Item C.2.2 +''' Next code will create the menu/submenu hierarchy +''' With myMenu +''' .AddItem("Item A") +''' .AddItem("Item B>Item B.1") +''' .AddItem("Item B>Item B.2") +''' .AddItem("---") +''' .AddItem("Item C>Item C.1>Item C.1.1") +''' .AddItem("Item C>Item C.1>Item C.1.2") +''' .AddItem("Item C>Item C.2>Item C.2.1") +''' .AddItem("Item C>Item C.2>Item C.2.2") +''' End With +''' +''' Service invocation: +''' Dim ui As Object, oDoc As Object, myMenu As Object +''' Set ui = CreateScriptService("UI") +''' Set oDoc = ui.GetDocument(ThisComponent) +''' Set myMenu = oDoc.CreateMenu("My own menu") +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/SF_Menu.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private ObjectType As String ' Must be MENU +Private ServiceName As String + + +' Menu descriptors +Private Component As Object ' the com.sun.star.lang.XComponent hosting the menu in its menubar +Private MenuBar As Object ' com.sun.star.awt.XMenuBar or stardiv.Toolkit.VCLXMenuBar +Private SubmenuChar As String ' Delimiter in menu trees +Private MenuHeader As String ' Header of the menu +Private MenuId As Integer ' Menu numeric identifier in the menubar +Private MenuPosition As Integer ' Position of the menu on the menubar >= 1 +Private PopupMenu As Object ' The underlying popup menu as a SF_PopupMenu object + +REM ============================================================ MODULE CONSTANTS + +Private Const _UnderlineAccessKeyChar = "~" +Private Const _DefaultSubmenuChar = ">" +Private Const cstUnoPrefix = ".uno:" +Private Const cstScriptArg = ":::" +Private Const cstNormal = "N" +Private Const cstCheck = "C" +Private Const cstRadio = "R" + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + ObjectType = "MENU" + ServiceName = "SFWidgets.Menu" + Set Component = Nothing + Set MenuBar = Nothing + SubmenuChar = _DefaultSubmenuChar + MenuHeader = "" + MenuId = -1 + MenuPosition = 0 + Set PopupMenu = Nothing +End Sub ' SFWidgets.SF_Menu Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFWidgets.SF_Menu Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + PopupMenu.Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFWidgets.SF_Menu Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ShortcutCharacter() As Variant +''' The ShortcutCharacter property specifies character preceding the underline access key + ShortcutCharacter = _PropertyGet("ShortcutCharacter") +End Property ' SFWidgets.SF_Menu.ShortcutCharacter (get) + +REM ----------------------------------------------------------------------------- +Property Get SubmenuCharacter() As Variant +''' The SubmenuCharacter property specifies the character string indicating +''' a sub-menu in a popup menu item + SubmenuCharacter = _PropertyGet("SubmenuCharacter") +End Property ' SFWidgets.SF_Menu.SubmenuCharacter (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AddCheckBox(Optional ByVal MenuItem As Variant _ + , Optional ByVal Name As Variant _ + , Optional ByVal Status As Variant _ + , Optional ByVal Icon As Variant _ + , Optional ByVal Tooltip As Variant _ + , Optional ByVal Command As Variant _ + , Optional ByVal Script As Variant _ + ) As Integer +''' Insert in the popup menu a new entry as a checkbox +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hierarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted +''' Name: The name identifying the item. Default = the last component of MenuItem. +''' Status: when True the item is selected. Default = False +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Command: A menu command like ".uno:About". The validity of the command is not checked. +''' Script: a Basic or Python script (determined by its URI notation) to be run when the item is clicked +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' Next string argument will be passed to the called script : a comma-separated string of 4 components: +''' - the menu header +''' - the name of the clicked menu item +''' - the numeric identifier of the clicked menu item +''' - "1" when the status is "checked", otherwise "0" +''' Arguments Command and Script are mutually exclusive. +''' Returns: +''' The numeric identification of the newly inserted item +''' Examples: +''' Dim iId As Integer +''' iId = myMenu.AddCheckBox("Menu top>Checkbox item", Status := True, Command := "Bold") + +Dim iId As Integer ' Return value +Dim sCommand As String ' Alias of either Command or Script + + +Const cstThisSub = "SFWidgets.Menu.AddCheckBox" +Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""], [Command=""""], [Script=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iId = 0 + +Check: + If IsMissing(Name) Or IsEmpty(Name) Then Name = "" + If IsMissing(Status) Or IsEmpty(Status) Then Status = False + If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = "" + If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = "" + If IsMissing(Command) Or IsEmpty(Command) Then Command = "" + If IsMissing(Script) Or IsEmpty(Script) Then Script = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Command, "Command", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Script, "Script", V_STRING) Then GoTo Catch + End If + + If Len(Command) > 0 Then + If Left(Command, Len(cstUnoPrefix)) = cstUnoPrefix Then sCommand = Command Else sCommand = cstUnoPrefix & Command + Else + sCommand = Script & cstScriptArg & MenuHeader + End If + +Try: + iId = PopupMenu._AddItem(MenuItem, Name, cstCheck, Status, Icon, Tooltip, sCommand) + +Finally: + AddCheckBox = iId + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Menu.AddCheckBox + +REM ----------------------------------------------------------------------------- +Public Function AddItem(Optional ByVal MenuItem As Variant _ + , Optional ByVal Name As Variant _ + , Optional ByVal Icon As Variant _ + , Optional ByVal Tooltip As Variant _ + , Optional ByVal Command As Variant _ + , Optional ByVal Script As Variant _ + ) As Integer +''' Insert in the popup menu a new entry +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hierarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to "---", a line separator is inserted and all other arguments are ignored +''' Name: The name identifying the item. Default = the last component of MenuItem. +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Command: A menu command like ".uno:About". The validity of the command is not checked. +''' Script: a Basic or Python script (determined by its URI notation) to be run when the item is clicked +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' Next string argument will be passed to the called script : a comma-separated string of 4 components: +''' - the menu header +''' - the name of the clicked menu item +''' - the numeric identifier of the clicked menu item +''' - "0" +''' Arguments Command and Script are mutually exclusive. +''' Returns: +''' The numeric identification of the newly inserted item +''' Examples: +''' Dim iId1 As Integer, iId2 As Integer +''' iId1 = myMenu.AddItem("Menu top>Normal item 1", Icon := "cmd.sc_cut.png", Command := "About") +''' iId2 = myMenu.AddItem("Menu top>Normal item 2", Script := "vnd.sun.star.script:myLib.Module1.ThisSub?language=Basic&location=document") + +Dim iId As Integer ' Return value +Dim sCommand As String ' Alias of either Command or Script + +Const cstThisSub = "SFWidgets.Menu.AddItem" +Const cstSubArgs = "MenuItem, [Name=""""], [Icon=""""], [Tooltip=""""], [Command=""""], [Script=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iId = 0 + +Check: + If IsMissing(Name) Or IsEmpty(Name) Then Name = "" + If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = "" + If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = "" + If IsMissing(Command) Or IsEmpty(Command) Then Command = "" + If IsMissing(Script) Or IsEmpty(Script) Then Script = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Command, "Command", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Script, "Script", V_STRING) Then GoTo Catch + End If + + If Len(Command) > 0 Then + If Left(Command, Len(cstUnoPrefix)) = cstUnoPrefix Then sCommand = Command Else sCommand = cstUnoPrefix & Command + Else + sCommand = Script & cstScriptArg & MenuHeader + End If + +Try: + iId = PopupMenu._AddItem(MenuItem, Name, cstNormal, False, Icon, Tooltip, sCommand) + +Finally: + AddItem = iId + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Menu.AddItem + +REM ----------------------------------------------------------------------------- +Public Function AddRadioButton(Optional ByVal MenuItem As Variant _ + , Optional ByVal Name As Variant _ + , Optional ByVal Status As Variant _ + , Optional ByVal Icon As Variant _ + , Optional ByVal Tooltip As Variant _ + , Optional ByVal Command As Variant _ + , Optional ByVal Script As Variant _ + ) As Integer +''' Insert in the popup menu a new entry as a radio button +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hieAddCheckBoxrarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted +''' Name: The name identifying the item. Default = the last component of MenuItem. +''' Status: when True the item is selected. Default = False +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Command: A menu command like ".uno:About". The validity of the command is not checked. +''' Script: a Basic or Python script (determined by its URI notation) to be run when the item is clicked +''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Scripting_Framework#Scripting_Framework_URI_Specification +''' Next string argument will be passed to the called script : a comma-separated string of 4 components: +''' - the menu header +''' - the name of the clicked menu item +''' - the numeric identifier of theclicked menu item +''' - "1" when the status is "checked", otherwise "0" +''' Arguments Command and Script are mutually exclusive. +''' Returns: +''' The numeric identification of the newly inserted item +''' Examples: +''' Dim iId As Integer +''' iId = myMenu.AddRadioButton("Menu top>Radio item", Status := True, Command := "Bold") + +Dim iId As Integer ' Return value +Dim sCommand As String ' Alias of either Command or Script + +Const cstThisSub = "SFWidgets.Menu.AddRadioButton" +Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""], [Command=""""], [Script=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iId = 0 + +Check: + If IsMissing(Name) Or IsEmpty(Name) Then Name = "" + If IsMissing(Status) Or IsEmpty(Status) Then Status = False + If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = "" + If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = "" + If IsMissing(Command) Or IsEmpty(Command) Then Command = "" + If IsMissing(Script) Or IsEmpty(Script) Then Script = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Command, "Command", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Script, "Script", V_STRING) Then GoTo Catch + End If + + If Len(Command) > 0 Then + If Left(Command, Len(cstUnoPrefix)) = cstUnoPrefix Then sCommand = Command Else sCommand = cstUnoPrefix & Command + Else + sCommand = Script & cstScriptArg & MenuHeader + End If + +Try: + iId = PopupMenu._AddItem(MenuItem, Name, cstRadio, Status, Icon, Tooltip, sCommand) + +Finally: + AddRadioButton = iId + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Menu.AddRadioButton + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "SFWidgets.Menu.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Menu.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "AddCheckBox" _ + , "AddItem" _ + , "AddRadioButton" _ + ) + +End Function ' SFWidgets.SF_Menu.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer a.AddItem("B>B1")class as an array + + Properties = Array( _ + "ShortcutCharacter" _ + , "SubmenuCharacter" _ + ) + +End Function ' SFWidgets.SF_Menu.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFWidgets.Menu.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Menu.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize(ByRef poComponent As Object _ + , psMenuHeader As String _ + , psBefore As String _ + , piBefore As Integer _ + , psSubmenuChar As String _ + ) +''' Complete the object creation process: +''' - Initialize the internal properties +''' - Initialize the menubar +''' - Determine the position and the internal id of the new menu +''' - Create the menu and its attached popup menu +''' Args: +''' poComponent: the parent component where the menubar is to be searched for +''' psMenuHeader: the header of the new menu. May or not contain a tilde "~" +''' psBefore, piBefore: the menu before which to create the new menu, as a string or as a number +''' psSubmenuChar: the submenus separator + +Dim oLayout As Object ' com.sun.star.comp.framework.LayoutManager +Dim sName As String ' Menu name +Dim iMenuId As Integer ' Menu identifier +Dim i As Integer +Const cstTilde = "~" + +Try: + ' Initialize the menubar + Set oLayout = poComponent.CurrentController.Frame.LayoutManager + Set MenuBar = oLayout.getElement("private:resource/menubar/menubar").XMenuBar + + ' Determine the new menu identifier and its position + ' Identifier = largest current identifier + 1 + MenuHeader = psMenuHeader + With MenuBar + For i = 0 To .ItemCount - 1 + iMenuId = .getItemId(i) + If iMenuId >= MenuId Then MenuId = iMenuId + 1 + If piBefore > 0 And piBefore = i + 1 Then + MenuPosition = piBefore + Else + sName = .getItemText(iMenuId) + If sName = psBefore Or Replace(sName, cstTilde, "") = psBefore Then MenuPosition = i + 1 + End If + Next i + If MenuPosition = 0 Then MenuPosition = .ItemCount + 1 + End With + + ' Store the submenu character + If Len(psSubmenuChar) > 0 Then SubmenuChar = psSubmenuChar + + ' Create the menu and the attached top popup menu + MenuBar.insertItem(MenuId, MenuHeader, 0, MenuPosition - 1) + PopupMenu = SFWidgets.SF_Register._NewPopupMenu(Array(Nothing, 0, 0, SubmenuChar)) + PopupMenu.MenubarMenu = True ' Special indicator for menus depending on menubar + MenuBar.setPopupMenu(MenuId, PopupMenu.MenuRoot) + + ' Initialize the listener on the top branch + SFWidgets.SF_MenuListener.SetMenuListener(PopupMenu.MenuRoot) + +Finally: + Exit Sub +End Sub ' SFWidgets.SF_Menu._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim vGet As Variant ' Return value +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFWidgets.Menu.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + _PropertyGet = Null + + Select Case UCase(psProperty) + Case UCase("ShortcutCharacter") + _PropertyGet = _UnderlineAccessKeyChar + Case UCase("SubmenuCharacter") + _PropertyGet = SubmenuChar + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Menu._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_Menu instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[Menu]: Name, Type (dialogname) + _Repr = "[Menu]: " & SF_String.Represent(PopupMenu.MenuTree.Keys()) & ", " & SF_String.Represent(PopupMenu.MenuIdentification.Items()) + +End Function ' SFWidgets.SF_Menu._Repr + +REM ============================================ END OF SFWIDGETS.SF_MENU + \ No newline at end of file diff --git a/wizards/source/sfwidgets/SF_MenuListener.xba b/wizards/source/sfwidgets/SF_MenuListener.xba new file mode 100644 index 000000000..6045f2dd8 --- /dev/null +++ b/wizards/source/sfwidgets/SF_MenuListener.xba @@ -0,0 +1,129 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFWidgets library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_MenuListener +''' =============== +''' The current module is dedicated to the management of menu events + listeners, triggered by user actions, +''' which cannot be defined with the Basic IDE +''' +''' Concerned listeners: +''' com.sun.star.awt.XMenuListener +''' allowing a user to select a menu command in user menus preset in the menubar +''' +''' The described events/listeners are processed by UNO listeners +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ============================================================= PRIVATE MEMBERS + +Dim MenuListener As Object ' com.sun.star.awt.XMenuListener + +REM =========================================================== PRIVATE CONSTANTS + +Private Const _MenuListenerPrefix = "_SFMENU_" +Private Const _MenuListener = "com.sun.star.awt.XMenuListener" +Private Const cstUnoPrefix = ".uno:" +Private Const cstScriptArg = ":::" + +REM ================================================================== EXCEPTIONS + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub SetMenuListener(poSubmenu As Object) +''' Arm a menu listener on a submenu +''' Args: +''' poSubmenu: the targeted submenu + +Try: + If IsNull(MenuListener) Then Set MenuListener = CreateUnoListener(_MenuListenerPrefix, _MenuListener) + poSubmenu.addMenuListener(MenuListener) + +Finally: + Exit Sub +End Sub ' SFWidgets.SF_MenuListener.SetMenuListener + +REM ============================================================= PRIVATE METHODS + +REM ----------------------------------------------------------------------------- +Sub _SFMENU_itemSelected(Optional poEvent As Object) ' com.sun.star.awt.MenuEvent +''' Execute the command or the script associated with the actually selected item +''' When a script, next argument is provided: +''' a comma-separated string with 4 components +''' - the menu header +''' - the name of the selected menu entry (without tilde "~") +''' - the numeric identifier of the selected menu entry +''' - the new status of the selected menu entry ("0" or "1"). Always "0" for usual items. + +Dim iMenuId As Integer +Dim oMenu As Object ' stardiv.Toolkit.VCLXPopupMenu +Dim sCommand As String ' Command associated with menu entry +Dim bType As Boolean ' True when status is meaningful: item is radio button or checkbox +Dim bStatus As Boolean ' Status of the menu item, always False for normal items +Dim oFrame As Object ' com.sun.star.comp.framework.Frame +Dim oDispatcher As Object ' com.sun.star.frame.DispatchHelper +Dim oSession As Object ' SF_Session service +Dim vScript As Variant ' Split command in script/argument +Dim oArgs() As new com.sun.star.beans.PropertyValue + + On Local Error GoTo Catch ' Avoid stopping event scripts + +Try: + iMenuId = poEvent.MenuId + oMenu = poEvent.Source + + With oMenu + ' Collect command (script or menu command) and status radiobuttons and checkboxes + sCommand = .getCommand(iMenuId) + bStatus = .isItemChecked(iMenuId) + End With + + If Len(sCommand) > 0 Then + If Left(sCommand, Len(cstUnoPrefix)) = cstUnoPrefix Then + ' Execute uno command + Set oFrame = StarDesktop.CurrentComponent.CurrentController.Frame ' A menu has been clicked necessarily in the current window + Set oDispatcher = ScriptForge.SF_Utils._GetUNOService("DispatchHelper") + oDispatcher.executeDispatch(oFrame, sCommand, "", 0, oArgs()) + oFrame.activate() + Else + ' Execute script + Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + vScript = Split(sCommand, cstScriptArg) + oSession._ExecuteScript(vScript(0), vScript(1) & "," & Iif(bStatus, "1", "0")) ' Return value is ignored + End If + End If + +Finally: + Exit Sub +Catch: + GoTo Finally +End Sub ' SFWidgets.SF_MenuListener._SFMENU_itemSelected + +REM ----------------------------------------------------------------------------- +Sub _SFMENU_itemHighlighted(Optional poEvent As Object) ' com.sun.star.awt.MenuEvent + Exit Sub +End Sub ' SFWidgets.SF_MenuListener._SFMENU_itemHighlighted + +Sub _SFMENU_itemActivated(Optional poEvent As Object) ' com.sun.star.awt.MenuEvent + Exit Sub +End Sub ' SFWidgets.SF_MenuListener._SFMENU_itemActivated + +Sub _SFMENU_itemDeactivated(Optional poEvent As Object) ' com.sun.star.awt.MenuEvent + Exit Sub +End Sub ' SFWidgets.SF_MenuListener._SFMENU_itemDeactivated + +Sub _SFMENU_disposing(Optional poEvent As Object) ' com.sun.star.awt.MenuEvent + Exit Sub +End Sub ' SFWidgets.SF_MenuListener._SFMENU_disposing + +REM ============================================ END OF SFDIALOGS.SF_DIALOGLISTENER + \ No newline at end of file diff --git a/wizards/source/sfwidgets/SF_PopupMenu.xba b/wizards/source/sfwidgets/SF_PopupMenu.xba new file mode 100644 index 000000000..3d5ba65a8 --- /dev/null +++ b/wizards/source/sfwidgets/SF_PopupMenu.xba @@ -0,0 +1,801 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFWidgets library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_PopupMenu +''' ============ +''' Display a popup menu anywhere and any time +''' +''' A popup menu is usually triggered by a mouse action (typically a right-click) on a dialog, a form +''' or one of their controls. In this case the menu will be displayed below the clicked area. +''' When triggered by other events, including in the normal flow of a user script, the script should +''' provide the coordinates of the topleft edge of the menu versus the actual component. +''' +''' The menu is described from top to bottom. Each menu item receives a numeric and a string identifier. +''' The Execute() method returns the item selected by the user. +''' +''' Menu items are either: +''' - usual items +''' - checkboxes +''' - radio buttons +''' - a menu separator +''' Menu items can be decorated with icons and tooltips. +''' +''' Definitions: +''' SubmenuCharacter: the character or the character string that identifies how menus are cascading +''' Default = ">" +''' Can be set when invoking the PopupMenu service +''' ShortcutCharacter: the underline access key character +''' Default = "~" +''' +''' Service invocation: +''' Sub OpenMenu(Optional poMouseEvent As Object) +''' Dim myMenu As Object +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent, , , ">>") ' Usual case +''' ' or +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", , X, Y, " | ") ' Use X and Y coordinates to place the menu +''' +''' Menus and submenus +''' To create a popup menu with submenus, use the character defined in the +''' SubmenuCharacter property while creating the menu entry to define where it will be +''' placed. For instance, consider the following menu/submenu hierarchy. +''' Item A +''' Item B > Item B.1 +''' Item B.2 +''' ------ (line separator) +''' Item C > Item C.1 > Item C.1.1 +''' Item C.1.2 +''' Item C > Item C.2 > Item C.2.1 +''' Item C.2.2 +''' Next code will create the menu/submenu hierarchy +''' With myMenu +''' .AddItem("Item A") +''' .AddItem("Item B>Item B.1") +''' .AddItem("Item B>Item B.2") +''' .AddItem("---") +''' .AddItem("Item C>Item C.1>Item C.1.1") +''' .AddItem("Item C>Item C.1>Item C.1.2") +''' .AddItem("Item C>Item C.2>Item C.2.1") +''' .AddItem("Item C>Item C.2>Item C.2.2") +''' End With +''' +''' Example 1: simulate a subset of the View menu in the menubar of the Basic IDE +''' Sub OpenMenu(Optional poMouseEvent As Object) +''' Dim myMenu As Object, vChoice As Variant +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent) +''' With myMenu +''' .AddCheckBox("View>Toolbars>Dialog") +''' .AddCheckBox("View>Toolbars>Find", Status := True) +''' .AddCheckBox("View>Status Bar", Status := True) +''' .AddItem("View>Full Screen", Name := "FULLSCREEN") +''' vChoice = .Execute(False) ' When 1st checkbox is clicked, return "Dialog" +''' ' When last item is clicked, return "FULLSCREEN" +''' .Dispose() +''' End With +''' +''' Example 2: jump to another sheet of a Calc document +''' ' Link next Sub to the "Mouse button released" event of a form control of a Calc sheet +''' Sub JumpToSheet(Optional poEvent As Object) +''' Dim myMenu As Object, sChoice As String, myDoc As Object, vSheets As Variant, sSheet As String +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent) +''' Set myDoc = CreateScriptService("Calc", ThisComponent) +''' vSheets = myDoc.Sheets +''' For Each sSheet In vSheets +''' myMenu.AddItem(sSheet) +''' Next sSheet +''' sChoice = myMenu.Execute(False) ' Return sheet name, not sheet index +''' If sChoice <> "" Then myDoc.Activate(sChoice) +''' myDoc.Dispose() +''' myMenu.Dispose() +''' End Sub +''' +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_popupmenu.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private ObjectType As String ' Must be POPUPMENU +Private ServiceName As String + + +' Menu descriptors +Private MenuTree As Variant ' Dictionary treename - XPopupMenu pair +Private MenuIdentification As Variant ' Dictionary item ID - item name +Private SubmenuChar As String ' Delimiter in menu trees +Private MenuRoot As Object ' stardiv.vcl.PopupMenu or com.sun.star.awt.XPopupMenu +Private LastItem As Integer ' Every item has its entry number. This is the last one +Private Rectangle As Object ' com.sun.star.awt.Rectangle +Private PeerWindow As Object ' com.sun.star.awt.XWindowPeer +Private MenubarMenu As Boolean ' When True, the actual popup menu depends on a menubar item + +REM ============================================================ MODULE CONSTANTS + +Private Const _UnderlineAccessKeyChar = "~" +Private Const _DefaultSubmenuChar = ">" +Private Const _SeparatorChar = "---" +Private Const _IconsDirectory = "private:graphicrepository/" ' Refers to <install folder>/share/config/images_*.zip. +Private Const cstUnoPrefix = ".uno:" +Private Const cstNormal = "N" +Private Const cstCheck = "C" +Private Const cstRadio = "R" + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + ObjectType = "POPUPMENU" + ServiceName = "SFWidgets.PopupMenu" + Set MenuTree = Nothing + Set MenuIdentification = Nothing + SubmenuChar = _DefaultSubmenuChar + Set MenuRoot = Nothing + LastItem = 0 + Set Rectangle = Nothing + Set PeerWindow = Nothing + MenubarMenu = False +End Sub ' SFWidgets.SF_PopupMenu Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFWidgets.SF_PopupMenu Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + If Not IsNull(MenuTree) Then Set MenuTree = MenuTree.Dispose() + If Not IsNull(MenuIdentification) Then Set MenuIdentification = MenuIdentification.Dispose() + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFWidgets.SF_PopupMenu Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get ShortcutCharacter() As Variant +''' The ShortcutCharacter property specifies character preceding the underline access key + ShortcutCharacter = _PropertyGet("ShortcutCharacter") +End Property ' SFWidgets.SF_PopupMenu.ShortcutCharacter (get) + +REM ----------------------------------------------------------------------------- +Property Get SubmenuCharacter() As Variant +''' The SubmenuCharacter property specifies the character string indicating +''' a sub-menu in a popup menu item + SubmenuCharacter = _PropertyGet("SubmenuCharacter") +End Property ' SFWidgets.SF_PopupMenu.SubmenuCharacter (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AddCheckBox(Optional ByVal MenuItem As Variant _ + , Optional ByVal Name As Variant _ + , Optional ByVal Status As Variant _ + , Optional ByVal Icon As Variant _ + , Optional ByVal Tooltip As Variant _ + ) As Integer +''' Insert in the popup menu a new entry +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hierarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted +''' Name: The name to be returned by the Execute() method if this item is clicked +''' Default = the last component of MenuItem +''' Status: when True the item is selected. Default = False +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Returns: +''' The numeric identification of the newly inserted item +''' Examples: +''' Dim myMenu As Object, iId As Integer +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent) +''' iId = myMenu.AddCheckBox("Menu top>Checkbox item", Status := True) + +Dim iId As Integer ' Return value + +Const cstThisSub = "SFWidgets.PopupMenu.AddCheckBox" +Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iId = 0 + +Check: + If IsMissing(Name) Or IsEmpty(Name) Then Name = "" + If IsMissing(Status) Or IsEmpty(Status) Then Status = False + If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = "" + If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch + End If + +Try: + iId = _AddItem(MenuItem, Name, cstCheck, Status, Icon, Tooltip) + +Finally: + AddCheckBox = iId + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu.AddCheckBox + +REM ----------------------------------------------------------------------------- +Public Function AddItem(Optional ByVal MenuItem As Variant _ + , Optional ByVal Name As Variant _ + , Optional ByVal Icon As Variant _ + , Optional ByVal Tooltip As Variant _ + ) As Integer +''' Insert in the popup menu a new entry +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hierarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to "---", a line separator is inserted and all other arguments are ignored +''' Name: The name to be returned by the Execute() method if this item is clicked +''' Default = the last component of MenuItem +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Returns: +''' The numeric identification of the newly inserted item +''' Examples: +''' Dim myMenu As Object, iId As Integer +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent) +''' iId = myMenu.AddItem("Menu top>Normal item", Icon := "cmd.sc_cut.png") + +Dim iId As Integer ' Return value + +Const cstThisSub = "SFWidgets.PopupMenu.AddItem" +Const cstSubArgs = "MenuItem, [Name=""""], [Icon=""""], [Tooltip=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iId = 0 + +Check: + If IsMissing(Name) Or IsEmpty(Name) Then Name = "" + If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = "" + If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch + End If + +Try: + iId = _AddItem(MenuItem, Name, cstNormal, False, Icon, Tooltip) + +Finally: + AddItem = iId + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu.AddItem + +REM ----------------------------------------------------------------------------- +Public Function AddRadioButton(Optional ByVal MenuItem As Variant _ + , Optional ByVal Name As Variant _ + , Optional ByVal Status As Variant _ + , Optional ByVal Icon As Variant _ + , Optional ByVal Tooltip As Variant _ + ) As Integer +''' Insert in the popup menu a new entry as a radio button +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hieAddCheckBoxrarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted +''' Name: The name to be returned by the Execute() method if this item is clicked +''' Default = the last component of MenuItem +''' Status: when True the item is selected. Default = False +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Returns: +''' The numeric identification of the newly inserted item +''' Examples: +''' Dim myMenu As Object, iId As Integer +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poEvent) +''' iId = myMenu.AddRadioButton("Menu top>Radio item", Status := True) + +Dim iId As Integer ' Return value + +Const cstThisSub = "SFWidgets.PopupMenu.AddRadioButton" +Const cstSubArgs = "MenuItem, [Name=""""], [Status=False], [Icon=""""], [Tooltip=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + iId = 0 + +Check: + If IsMissing(Name) Or IsEmpty(Name) Then Name = "" + If IsMissing(Status) Or IsEmpty(Status) Then Status = False + If IsMissing(Icon) Or IsEmpty(Icon) Then Icon = "" + If IsMissing(Tooltip) Or IsEmpty(Tooltip) Then Tooltip = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(MenuItem, "MenuItem", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Name, "Name", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Status, "Status", ScriptForge.V_BOOLEAN) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Icon, "Icon", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Tooltip, "Tooltip", V_STRING) Then GoTo Catch + End If + +Try: + iId = _AddItem(MenuItem, Name, cstRadio, Status, Icon, Tooltip) + +Finally: + AddRadioButton = iId + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu.AddRadioButton + +REM ----------------------------------------------------------------------------- +Public Function Execute(Optional ByVal ReturnId As Variant) As Variant +''' Display the popup menu and return the menu item clicked by the user +''' Args: +''' ReturnId: When True (default), return the unique ID of the clicked item, otherwise return its name +''' Returns: +''' The numeric identification of clicked item or its name +''' The returned value is 0 or "" (depending on ReturnId) when the menu is cancelled +''' Examples: +''' Sub OpenMenu(Optional poMouseEvent As Object) +''' Dim myMenu As Object, vChoice As Variant +''' Set myMenu = CreateScriptService("SFWidgets.PopupMenu", poMouseEvent) +''' With myMenu +''' .AddCheckBox("View>Toolbars>Dialog") +''' .AddCheckBox("View>Toolbars>Find", STatus := True) +''' .AddCheckBox("View>Status Bar", STatus := True) +''' .AddItem("View>Full Screen", Name := "FULLSCREEN") +''' vChoice = .Execute(False) ' When 1st checkbox is clicked, return "Dialog" +''' ' When last item is clicked, return "FULLSCREEN" +''' End With + +Dim vMenuItem As Variant ' Return value + +Const cstThisSub = "SFWidgets.PopupMenu.Execute" +Const cstSubArgs = "[ReturnId=True]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + vMenuItem = 0 + +Check: + If IsMissing(ReturnId) Or IsEmpty(ReturnId) Then ReturnId = True + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(ReturnId, "ReturnId", ScriptForge.V_BOOLEAN) Then GoTo Catch + End If + If Not ReturnId Then vMenuItem = "" + +Try: + vMenuItem = MenuRoot.Execute(PeerWindow, Rectangle, com.sun.star.awt.PopupMenuDirection.EXECUTE_DEFAULT) + If Not ReturnId Then vMenuItem = MenuIdentification.Item(CStr(vMenuItem)) + +Finally: + Execute = vMenuItem + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu.Execute + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "SFWidgets.PopupMenu.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "AddCheckBox" _ + , "AddItem" _ + , "AddRadioButton" _ + , "Execute" _ + ) + +End Function ' SFWidgets.SF_PopupMenu.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer a.AddItem("B>B1")class as an array + + Properties = Array( _ + "ShortcutCharacter" _ + , "SubmenuCharacter" _ + ) + +End Function ' SFWidgets.SF_PopupMenu.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFWidgets.PopupMenu.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu.SetProperty + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _AddItem(ByVal MenuItem As String _ + , ByVal Name As String _ + , ByVal ItemType As String _ + , ByVal Status As Boolean _ + , ByVal Icon As String _ + , ByVal Tooltip As String _ + , Optional ByVal Command As String _ + ) As Integer +''' Insert in the popup menu a new entry +''' Args: +''' MenuItem: The text to be displayed in the menu entry. +''' It determines also the hierarchy of the popup menu +''' It is made up of all the components (separated by the "SubmenuCharacter") of the menu branch +''' Example: A>B>C means "C" is a new entry in submenu "A => B =>" +''' If the last component is equal to the "SeparatorCharacter", a line separator is inserted +''' Name: The name to be returned by the Execute() method if this item is clicked +''' Default = the last component of MenuItem +''' ItemType: "N"(ormal, "C"(heck) or "R"(adio) +''' Status: when True the item is selected +''' Icon: The path name of the icon to be displayed, without leading path separator +''' The icons are stored in one of the <install folder>/share/config/images_*.zip files +''' The exact file depends on the user options about the current icon set +''' Use the (normal) slash "/" as path separator +''' Example: "cmd/sc_cut.png" +''' Tooltip: The help text to be displayed as a tooltip +''' Command: only for menubar menus +''' Either a uo command like ".uno:About" +''' or a script to be run: script URI ::: string argument to be passed to the script +''' Returns: +''' The numeric identification of the newly inserted item + +Dim iId As Integer ' Return value +Dim vSplit As Variant ' Split menu item +Dim sMenu As String ' Submenu where to attach the new item, as a string +Dim oMenu As Object ' Submenu where to attach the new item, as an object +Dim sName As String ' The text displayed in the menu box +Dim oImage As Object ' com.sun.star.graphic.XGraphic +Dim sCommand As String ' Alias of Command completed with arguments +Const cstCommandSep = "," + + On Local Error GoTo Catch + iId = 0 + If IsMissing(Command) Then Command = "" + +Try: + ' Run through the upper menu tree + vSplit = _SplitMenuItem(MenuItem) + + ' Create and determine the menu to which to attach the new item + sMenu = vSplit(0) + Set oMenu = _GetPopupMenu(sMenu) ' Run through the upper menu tree and retain the last branch + + ' Insert the new item + LastItem = LastItem + 1 + sName = vSplit(1) + + With oMenu + If sName = _SeparatorChar Then + .insertSeparator(-1) + Else + Select Case ItemType + Case cstNormal + .insertItem(LastItem, sName, 0, -1) + Case cstCheck + .insertItem(LastItem, sName, com.sun.star.awt.MenuItemStyle.CHECKABLE + com.sun.star.awt.MenuItemStyle.AUTOCHECK, -1) + .checkItem(LastItem, Status) + Case cstRadio + .insertItem(LastItem, sName, com.sun.star.awt.MenuItemStyle.RADIOCHECK + com.sun.star.awt.MenuItemStyle.AUTOCHECK, -1) + .checkItem(LastItem, Status) + End Select + + ' Store the ID - Name relation + If Len(Name) = 0 Then Name = Replace(sName, _UnderlineAccessKeyChar, "") + MenuIdentification.Add(CStr(LastItem), Name) + + ' Add the icon when relevant + If Len(Icon) > 0 Then + Set oImage = _GetImageFromUrl(_IconsDirectory & Icon) + If Not IsNull(oImage) Then .setItemImage(LastItem, oImage, False) + End If + + ' Add the tooltip when relevant + If Len(Tooltip) > 0 Then .setTipHelpText(LastItem, Tooltip) + + ' Add the command: UNO command or script to run - menubar menus only + If Len(Command) > 0 Then + If Left(Command, Len(cstUnoPrefix)) = cstUnoPrefix Then + sCommand = Command + Else + sCommand = Command & cstCommandSep & Name & cstCommandSep & CStr(LastItem) + End If + .setCommand(LastItem, sCommand) + End If + End If + End With + + iId = LastItem + +Finally: + _AddItem = iId + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu._AddItem + +REM ----------------------------------------------------------------------------- +Private Function _GetImageFromURL(ByVal psUrl as String) As Object +''' Returns a com.sun.star.graphic.XGraphic instance based on the given URL +''' The returned object is intended to be inserted as an icon in the popup menu +''' Derived from "Useful Macro Information For OpenOffice" By Andrew Pitonyak + +Dim vMediaProperties As Variant ' Array of com.sun.star.beans.PropertyValue +Dim oGraphicProvider As Object ' com.sun.star.graphic.GraphicProvider +Dim oImage As Object ' Return value + + On Local Error GoTo Catch ' Ignore errors + Set oImage = Nothing + +Try: + ' Create graphic provider instance to load images from files. + Set oGraphicProvider = CreateUnoService("com.sun.star.graphic.GraphicProvider") + + ' Set the URL property so graphic provider is able to load the image + Set vMediaProperties = Array(ScriptForge.SF_Utils._MakePropertyValue("URL", psURL)) + + ' Retrieve the com.sun.star.graphic.XGraphic instance + Set oImage = oGraphicProvider.queryGraphic(vMediaProperties) + +Finally: + Set _GetImageFromUrl = oImage + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu._GetImageFromUrl + +REM ----------------------------------------------------------------------------- +Private Function _GetPopupMenu(ByVal psSubmenu As String) As Object +''' Get the com.sun.star.awt.XPopupMenu object corresponding with the string in argument +''' If the menu exists, it is found in the MenuTree dictionary +''' If it does not exist, it is created recursively. +''' Args: +''' psSubmenu: a string like "A>B" +''' Returns +''' A com.sun.star.awt.XpopupMenu object +''' Example +''' If psSubmenu = "A>B>C>D", and only the root menu exists, +''' - "A", "A>B", "A>B>C", "A>B>C>D" should be created +''' - the popup menu corresponding with "A>B>C>D" should be returned + +Dim oPopup As Object ' Return value +Dim vSplit As Variant ' An array as returned by _SplitMenuItem() +Dim sMenu As String ' The left part of psSubmenu +Dim oMenu As Object ' com.sun.star.awt.XpopupMenu +Dim oLastMenu As Object ' com.sun.star.awt.XpopupMenu +Dim i As Long + + Set oPopup = Nothing + Set oLastMenu = MenuRoot +Try: + If Len(psSubmenu) = 0 Then ' Menu starts at the root + Set oPopup = MenuRoot + ElseIf MenuTree.Exists(psSubmenu) Then ' Shortcut: if the submenu exists, get it directly + Set oPopup = MenuTree.Item(psSubmenu) + Else ' Build the tree + vSplit = Split(psSubmenu, SubmenuChar) + ' Search the successive submenus in the MenuTree dictionary, If not found, create a new entry + For i = 0 To UBound(vSplit) + sMenu = Join(ScriptForge.SF_Array.Slice(vSplit, 0, i), SubmenuChar) + If MenuTree.Exists(sMenu) Then + Set oLastMenu = MenuTree.Item(sMenu) + Else + ' Insert the new menu tree item + LastItem = LastItem + 1 + oLastMenu.insertItem(LastItem, vSplit(i), 0, -1) + Set oMenu = CreateUnoService("stardiv.vcl.PopupMenu") + If MenubarMenu Then SFWidgets.SF_MenuListener.SetMenuListener(oMenu) + MenuTree.Add(sMenu, oMenu) + oLastMenu.setPopupMenu(LastItem, oMenu) + Set oLastMenu = oMenu + End If + Next i + Set oPopup = oLastMenu + End If + +Finally: + Set _GetPopupMenu = oPopup + Exit Function +End Function ' SFWidgets.SF_PopupMenu._GetPopupMenu + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize(ByRef poPeer As Object _ + , plXPos As Long _ + , plYPos As Long _ + , psSubmenuChar As String _ + ) +''' Complete the object creation process: +''' - Initialize the dictionaries +''' - initialize the root popup menu +''' - initialize the display area +''' - store the arguments for later use +''' Args: +''' poPeer: a peer window +''' plXPos, plYPos: the coordinates + +Try: + ' Initialize the dictionaries + With ScriptForge.SF_Services + Set MenuTree = .CreateScriptService("Dictionary") + Set MenuIdentification = .CreateScriptService("Dictionary") + End With + + ' Initialize the root of the menu tree + Set MenuRoot = CreateUnoService("stardiv.vcl.PopupMenu") + + ' Setup the display area + Set Rectangle = New com.sun.star.awt.Rectangle + Rectangle.X = plXPos + Rectangle.Y = plYPos + + ' Keep the targeted window + Set PeerWindow = poPeer + + ' Store the submenu character + If Len(psSubmenuChar) > 0 Then SubmenuChar = psSubmenuChar + +Finally: + Exit Sub +End Sub ' SFWidgets.SF_PopupMenu._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property + +Dim vGet As Variant ' Return value +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFWidgets.PopupMenu.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + _PropertyGet = Null + + Select Case UCase(psProperty) + Case UCase("ShortcutCharacter") + _PropertyGet = _UnderlineAccessKeyChar + Case UCase("SubmenuCharacter") + _PropertyGet = SubmenuChar + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_PopupMenu._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the SF_PopupMenu instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[PopupMenu]: Name, Type (dialogname) + _Repr = "[PopupMenu]: " & SF_String.Represent(MenuTree.Keys()) & ", " & SF_String.Represent(MenuIdentification.Items()) + +End Function ' SFWidgets.SF_PopupMenu._Repr + +REM ----------------------------------------------------------------------------- +Private Function _SplitMenuItem(ByVal psMenuItem As String ) As Variant +''' Split a menu item given as a string and delimited by the submenu character +''' Args: +''' psMenuItem: a string like "A>B>C" +''' Returns: +''' An array: [0] = "A>B" +''' [1] = "C" + +Dim vReturn(0 To 1) As String ' Return value +Dim vMenus() As Variant ' Array of menus + +Try: + vMenus = Split(psMenuItem, SubmenuChar) + vReturn(1) = vMenus(UBound(vMenus)) + vReturn(0) = Left(psMenuItem, Len(psMenuItem) - Iif(UBound(vMenus) > 0, Len(SubmenuChar), 0) - Len(vReturn(1))) + +Finally: + _SplitMenuItem = vReturn +End Function ' SFWidgets.SF_PopupMenu._SplitMenuItem + +REM ============================================ END OF SFWIDGETS.SF_POPUPMENU + \ No newline at end of file diff --git a/wizards/source/sfwidgets/SF_Register.xba b/wizards/source/sfwidgets/SF_Register.xba new file mode 100644 index 000000000..2c58b858d --- /dev/null +++ b/wizards/source/sfwidgets/SF_Register.xba @@ -0,0 +1,184 @@ + + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFWidgets library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''' - _NewMenu +''' Create a new menu service instance. +''' Called from SFDocuments services with CreateMenu() +''' - _NewPopupMenu +''' Create a new popup menu service instance. +''' Called from CreateScriptService() +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +REM ================================================================= DEFINITIONS + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("Menu", "SFWidgets.SF_Register._NewMenu") ' Reference to the function initializing the service + .RegisterService("PopupMenu", "SFWidgets.SF_Register._NewPopupMenu") ' id. + End With + +End Sub ' SFWidgets.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _NewMenu(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_Menu class +''' [called internally from SFDocuments.Document.CreateMenu() ONLY] +''' Args: +''' Component: the com.sun.star.lang.XComponent where to find the menubar to plug the new menu in +''' Header: the name/header of the menu +''' Before: the place where to put the new menu on the menubar (string or number >= 1) +''' When not found => last position +''' SubmenuChar: the delimiter used in menu trees. Default = ">" +''' Returns: the instance or Nothing + +Dim oMenu As Object ' Return value +Dim oComponent As Object ' The document or formdocument's component - com.sun.star.lang.XComponent +Dim sHeader As String ' Menu header +Dim sBefore As String ' Position of menu as a string +Dim iBefore As Integer ' as a number +Dim sSubmenuChar As String ' Delimiter in menu trees + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oMenu = Nothing + +Check: + ' Types and number of arguments are not checked because internal call only + Set oComponent = pvArgs(0) + sHeader = pvArgs(1) + Select Case VarType(pvArgs(2)) + Case V_STRING : sBefore = pvArgs(2) + iBefore = 0 + Case Else : sBefore = "" + iBefore = pvArgs(2) + End Select + sSubmenuChar = pvArgs(3) + +Try: + If Not IsNull(oComponent) Then + Set oMenu = New SF_Menu + With oMenu + Set .[Me] = oMenu + ._Initialize(oComponent, sHeader, sBefore, iBefore, sSubmenuChar) + End With + End If + +Finally: + Set _NewMenu = oMenu + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Register._NewMenu + +REM ----------------------------------------------------------------------------- +Public Function _NewPopupMenu(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_PopupMenu class +''' Args: +''' Event: a mouse event +''' If the event has no source or is not a mouse event, the menu is displayed above ThisComponent +''' X, Y: forced coordinates +''' SubmenuChar: Delimiter used in menu trees +''' Returns: the instance or Nothing + +Dim oMenu As Object ' Return value +Dim Event As Variant ' Mouse event +Dim X As Long ' Mouse click coordinates +Dim Y As Long +Dim SubmenuChar As String ' Delimiter in menu trees +Dim oSession As Object ' ScriptForge.SF_Session +Dim vUno As Variant ' UNO type split into an array +Dim sEventType As String ' Event type, must be "MouseEvent" +Dim oControl As Object ' The dialog or form control view which triggered the event + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs) + If UBound(pvArgs) >= 0 Then Event = pvArgs(0) Else Event = Nothing + If IsEmpty(Event) Then Event = Nothing + If UBound(pvArgs) >= 1 Then X = pvArgs(1) Else X = 0 + If UBound(pvArgs) >= 2 Then Y = pvArgs(2) Else Y = 0 + If UBound(pvArgs) >= 3 Then SubmenuChar = pvArgs(3) Else SubmenuChar = "" + If Not ScriptForge.SF_Utils._Validate(Event, "Event", ScriptForge.V_OBJECT) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(X, "X", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Y, "Y", ScriptForge.V_NUMERIC) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(SubmenuChar, "SubmenuChar", V_STRING) Then GoTo Finally + Set oMenu = Nothing + +Try: + Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Set oControl = Nothing + If Not IsNull(Event) Then + ' Determine the X, Y coordinates + vUno = Split(oSession.UnoObjectType(Event), ".") + sEventType = vUno(UBound(vUno)) + If UCase(sEventType) = "MOUSEEVENT" Then + X = Event.X + Y = Event.Y + ' Determine the window peer target + If oSession.HasUnoProperty(Event, "Source") Then Set oControl = Event.Source.Peer + End If + End If + ' If not a mouse event, if no control, ... + If IsNull(oControl) Then + If Not IsNull(ThisComponent) Then Set oControl = ThisComponent.CurrentController.Frame.getContainerWindow() + End If + + If Not IsNull(oControl) Then + Set oMenu = New SF_PopupMenu + With oMenu + Set .[Me] = oMenu + ._Initialize(oControl, X, Y, SubmenuChar) + End With + Else + Set oMenu = Nothing + End If + +Finally: + Set _NewPopupMenu = oMenu + Exit Function +Catch: + GoTo Finally +End Function ' SFWidgets.SF_Register._NewPopupMenu + +REM ============================================== END OF SFWidgets.SF_REGISTER + \ No newline at end of file diff --git a/wizards/source/sfwidgets/__License.xba b/wizards/source/sfwidgets/__License.xba new file mode 100644 index 000000000..0d0990e37 --- /dev/null +++ b/wizards/source/sfwidgets/__License.xba @@ -0,0 +1,26 @@ + + + +''' Copyright 2019-2022 Jean-Pierre LEDURE, Rafael LIMA, Alain ROMEDENNE + +REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFWidgets library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +''' ScriptForge is distributed in the hope that it will be useful, +''' but WITHOUT ANY WARRANTY; without even the implied warranty of +''' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +''' ScriptForge is free software; you can redistribute it and/or modify it under the terms of either (at your option): + +''' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not +''' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ . + +''' 2) The GNU Lesser General Public License as published by +''' the Free Software Foundation, either version 3 of the License, or +''' (at your option) any later version. If a copy of the LGPL was not +''' distributed with this file, see http://www.gnu.org/licenses/ . + + \ No newline at end of file diff --git a/wizards/source/sfwidgets/dialog.xlb b/wizards/source/sfwidgets/dialog.xlb new file mode 100644 index 000000000..5d45468be --- /dev/null +++ b/wizards/source/sfwidgets/dialog.xlb @@ -0,0 +1,3 @@ + + + \ No newline at end of file diff --git a/wizards/source/sfwidgets/script.xlb b/wizards/source/sfwidgets/script.xlb new file mode 100644 index 000000000..40e9f4c23 --- /dev/null +++ b/wizards/source/sfwidgets/script.xlb @@ -0,0 +1,9 @@ + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/standard/Module1.xba b/wizards/source/standard/Module1.xba new file mode 100644 index 000000000..3424c168e --- /dev/null +++ b/wizards/source/standard/Module1.xba @@ -0,0 +1,24 @@ + + + +REM ***** BASIC ***** + +Sub Main + +End Sub \ No newline at end of file diff --git a/wizards/source/standard/dialog.xlb b/wizards/source/standard/dialog.xlb new file mode 100644 index 000000000..669529dbc --- /dev/null +++ b/wizards/source/standard/dialog.xlb @@ -0,0 +1,3 @@ + + + diff --git a/wizards/source/standard/script.xlb b/wizards/source/standard/script.xlb new file mode 100644 index 000000000..67c9503b7 --- /dev/null +++ b/wizards/source/standard/script.xlb @@ -0,0 +1,5 @@ + + + + + diff --git a/wizards/source/template/Autotext.xba b/wizards/source/template/Autotext.xba new file mode 100644 index 000000000..35b3fdf62 --- /dev/null +++ b/wizards/source/template/Autotext.xba @@ -0,0 +1,190 @@ + + + +Option Explicit + +Public UserfieldDataType(14) as String +Public oDocAuto as Object +Public BulletList(7) as Integer +Public sTextFieldNotDefined as String +Public sGeneralError as String + + +Sub Main() + Dim oCursor as Object + Dim oStyles as Object + Dim oSearchDesc as Object + Dim oFoundall as Object + Dim oFound as Object + Dim i as Integer + Dim sFoundString as String + Dim sFoundContent as String + Dim FieldStringThere as String + Dim ULStringThere as String + Dim PHStringThere as String + On Local Error Goto GENERALERROR + ' Initialization... + BasicLibraries.LoadLibrary("Tools") + If InitResources("'Template'") Then + sGeneralError = GetResText("CorrespondenceMsgError") + sTextFieldNotDefined = GetResText("TextField") + End If + + UserfieldDatatype(0) = "COMPANY" + UserfieldDatatype(1) = "FIRSTNAME" + UserfieldDatatype(2) = "NAME" + UserfieldDatatype(3) = "SHORTCUT" + UserfieldDatatype(4) = "STREET" + UserfieldDatatype(5) = "COUNTRY" + UserfieldDatatype(6) = "ZIP" + UserfieldDatatype(7) = "CITY" + UserfieldDatatype(8) = "TITLE" + UserfieldDatatype(9) = "POSITION" + UserfieldDatatype(10) = "PHONE_PRIVATE" + UserfieldDatatype(11) = "PHONE_COMPANY" + UserfieldDatatype(12) = "FAX" + UserfieldDatatype(13) = "EMAIL" + UserfieldDatatype(14) = "STATE" + BulletList(0) = 149 + BulletList(1) = 34 + BulletList(2) = 65 + BulletList(3) = 61 + BulletList(4) = 49 + BulletList(5) = 47 + BulletList(6) = 79 + BulletList(7) = 58 + + oDocAuto = ThisComponent + oStyles = oDocAuto.Stylefamilies.GetByName("NumberingStyles") + + ' Prepare the Search-Descriptor + oSearchDesc = oDocAuto.createsearchDescriptor() + oSearchDesc.SearchRegularExpression = True + oSearchDesc.SearchWords = True + oSearchDesc.SearchString = "<[^>]+>" + oFoundall = oDocAuto.FindAll(oSearchDesc) + + 'Loop over the foundings + For i = 0 To oFoundAll.Count - 1 + oFound = oFoundAll.GetByIndex(i) + sFoundString = oFound.String + 'Extract the string inside the brackets + sFoundContent = FindPartString(sFoundString,"<",">",1) + sFoundContent = LTrim(sFoundContent) + + ' Define the Cursor and place it on the founding + oCursor = oFound.Text.CreateTextCursorbyRange(oFound) + + ' Find out, which object is to be created... + FieldStringThere = Instr(1,sFoundContent,"Field") + ULStringThere = Instr(1,sFoundContent,"UL") + PHStringThere = Instr(1,sFoundContent,"Placeholder") + If FieldStringThere = 1 Then + CreateUserDatafield(oCursor, sFoundContent) + ElseIf ULStringThere = 1 Then + CreateBullet(oCursor, oStyles) + ElseIf PHStringThere = 1 Then + CreatePlaceholder(oCursor, sFoundContent) + End If + Next i + + GENERALERROR: + If Err <> 0 Then + Msgbox(sGeneralError,16, GetProductName()) + Resume LETSGO + End If + LETSGO: +End Sub + + +' creates a User - datafield out of a string with the following structure +' "<field:Company>" +Sub CreateUserDatafield(oCursor, sFoundContent as String) + Dim MaxIndex as Integer + Dim sFoundList(3) + Dim oUserfield as Object + Dim UserInfo as String + Dim UserIndex as Integer + + oUserfield = oDocAuto.CreateInstance("com.sun.star.text.TextField.ExtendedUser") + sFoundList() = ArrayoutofString(sFoundContent,":",MaxIndex) + UserInfo = UCase(LTrim(sFoundList(1))) + UserIndex = IndexInArray(UserInfo, UserfieldDatatype()) + If UserIndex <> -1 Then + oUserField.UserDatatype = UserIndex + oCursor.Text.InsertTextContent(oCursor,oUserField,True) + oUserField.IsFixed = True + Else + Msgbox(UserInfo &": " & sTextFieldNotDefined,16, GetProductName()) + End If +End Sub + + +' Creates a Bullet by setting a soft Formatation on the first unsorted List-Templates with a defined +' Bullet Id +Sub CreateBullet(oCursor, oStyles as Object) + Dim n, m, s as Integer + Dim StyleSet as Boolean + Dim ostyle as Object + Dim StyleName as String + Dim alevel() + StyleSet = False + For s = 0 To Ubound(BulletList()) + For n = 0 To oStyles.Count - 1 + ostyle = oStyles.getbyindex(n) + StyleName = oStyle.Name + alevel() = ostyle.NumberingRules.getbyindex(0) + ' The properties of the style are stored in a Name-Value-Array() + For m = 0 to Ubound(alevel()) + ' Set the first Numbering template without a bulletID + If (aLevel(m).Name = "BulletId") Then + If alevel(m).Value = BulletList(s) Then + oCursor.NumberingStyle = StyleName + oCursor.SetString("") + exit Sub + End if + End If + Next m + Next n + Next s + If Not StyleSet Then + ' The Template with the demanded BulletID is not available, so take the first style in the sequence + ' that has a defined Bullet ID + oCursor.NumberingStyleName = oStyles.GetByIndex(5).Name + oCursor.SetString("") + End If +End Sub + + +' Creates a placeholder out of a string with the following structure: +'<placeholder:Showtext:Helptext> +Sub CreatePlaceholder(oCursor as Object, sFoundContent as String) + Dim oPlaceholder as Object + Dim MaxIndex as Integer + Dim sFoundList(3) + oPlaceholder = oDocAuto.CreateInstance("com.sun.star.text.TextField.JumpEdit") + sFoundList() = ArrayoutofString(sFoundContent, ":" & chr(34),MaxIndex) + ' Delete The Double-quotes + oPlaceholder.Hint = DeleteStr(sFoundList(2),chr(34)) + oPlaceholder.placeholder = DeleteStr(sFoundList(1),chr(34)) + oCursor.Text.InsertTextContent(oCursor,oPlaceholder,True) +End Sub + + + diff --git a/wizards/source/template/Correspondence.xba b/wizards/source/template/Correspondence.xba new file mode 100644 index 000000000..01da7f3d8 --- /dev/null +++ b/wizards/source/template/Correspondence.xba @@ -0,0 +1,303 @@ + + + +Option Explicit + +Public msgNoTextmark$, msgError$ +Public sAddressbook$ +Public Table +Public sCompany$, sFirstName$, sLastName$, sStreet$, sPostalCode$, sCity$, sState$, sInitials$, sPosition$ +Public DialogExited +Public oDocument, oText, oBookMarks, oBookMark, oBookMarkCursor, oBookText as Object +Public bTemplate, bDBFields as Boolean + +Sub Main + bTemplate = true + BasicLibraries.LoadLibrary("Tools") + TemplateDialog = LoadDialog("Template", "TemplateDialog") + DialogModel = TemplateDialog.Model + DialogModel.Step = 2 + DialogModel.Optmerge.State = True + LoadLanguageCorrespondence() + TemplateDialog.Execute + TemplateDialog.Dispose() +End Sub + + +Sub Placeholder + bTemplate = false + BasicLibraries.LoadLibrary("Tools") + LoadLanguageCorrespondence() + bDBFields = false + OK() +End Sub + + +Sub Database + bTemplate = false + BasicLibraries.LoadLibrary("Tools") + LoadLanguageCorrespondence() + bDBFields = true + OK() +End Sub + + +Function LoadLanguageCorrespondence() as Boolean + If InitResources("'Template'") Then + msgNoTextmark$ = GetResText("CorrespondenceDialog_0") & Chr(13) & Chr(10) & GetResText("CorrespondenceNoTextmark_1") + msgError$ = GetResText("CorrespondenceMsgError") + If bTemplate Then + DialogModel.Title = GetResText("CorrespondenceDialog_3") + DialogModel.CmdCancel.Label = GetResText("STYLES_2") + DialogModel.CmdCorrGoOn.Label = GetResText("STYLES_3") + DialogModel.OptSingle.Label = GetResText("CorrespondenceDialog_1") + DialogModel.Optmerge.Label = GetResText("CorrespondenceDialog_2") + DialogModel.FrmLetter.Label = GetResText("CorrespondenceDialog_0") + End If + LoadLanguageCorrespondence() = True + Else + msgbox("Warning: Resource could not be loaded!") + End If +End Function + + +Function GetFieldName(oFieldKnot as Object, GeneralFieldName as String) + If oFieldKnot.HasByName(GeneralFieldName) Then + GetFieldName = oFieldKnot.GetByName(GeneralFieldName).AssignedFieldName + Else + GetFieldName = "" + End If +End Function + + +Sub OK +Dim ParaBreak +Dim sDocLang as String +Dim oSearchDesc as Object +Dim oFoundAll as Object +Dim oFound as Object +Dim sFoundContent as String +Dim sFoundString as String +Dim sDBField as String +Dim i as Integer +Dim oDBAccess as Object +Dim oAddressDialog as Object +Dim oAddressPilot as Object +Dim oFields as Object +Dim oDocSettings as Object +Dim oContext as Object +Dim bDBvalid as Boolean + 'On Local Error Goto GENERALERROR + + If bTemplate Then + bDBFields = DialogModel.Optmerge.State 'database or placeholder + TemplateDialog.EndExecute() + DialogExited = TRUE + End If + + If bDBFields Then + oDBAccess = GetRegistryKeyContent("org.openoffice.Office.DataAccess/AddressBook/") + sAddressbook = oDBAccess.DataSourceName + + bDBvalid = false + oContext = createUnoService( "com.sun.star.sdb.DatabaseContext" ) + + If (not isNull(oContext)) Then + 'Is the previously assigned address data source still valid? + bDBvalid = oContext.hasByName(sAddressbook) + end if + + If (bDBvalid = false) Then + oAddressPilot = createUnoService("com.sun.star.ui.dialogs.AddressBookSourcePilot") + oAddressPilot.execute + + oDBAccess = GetRegistryKeyContent("org.openoffice.Office.DataAccess/AddressBook/") + sAddressbook = oDBAccess.DataSourceName + If sAddressbook = "" Then + MsgBox(GetResText("CorrespondenceNoTextmark_1")) + Exit Sub + End If + End If + oFields = oDBAccess.GetByName("Fields") + Table = oDBAccess.GetByName("Command") + End If + + ParaBreak = com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK + oDocument = ThisComponent + If bDBFields Then + 'set the address db as current db at the document + oDocSettings = oDocument.createInstance("com.sun.star.document.Settings") + oDocSettings.CurrentDatabaseDataSource = sAddressbook + oDocSettings.CurrentDatabaseCommand = Table + oDocSettings.CurrentDatabaseCommandType = 0 + End If + oBookmarks = oDocument.Bookmarks + oText = oDocument.Text + + oSearchDesc = oDocument.createsearchDescriptor() + oSearchDesc.SearchRegularExpression = True + oSearchDesc.SearchWords = True + oSearchDesc.SearchString = "<[^>]+>" + oFoundall = oDocument.FindAll(oSearchDesc) + + 'Loop over the foundings + For i = oFoundAll.Count -1 To 0 Step -1 + oFound = oFoundAll.GetByIndex(i) + sFoundString = oFound.String + 'Extract the string inside the brackets + sFoundContent = FindPartString(sFoundString,"<",">",1) + sFoundContent = LTrim(sFoundContent) + ' Define the Cursor and place it on the founding + oBookmarkCursor = oFound.Text.CreateTextCursorbyRange(oFound) + oBookText = oFound.Text + If bDBFields Then + sDBField = GetFieldname(oFields, sFoundContent) + If sDBField <> "" Then + InsertDBField(sAddressbook, Table, sDBField) + Else + InsertPlaceholder(sFoundContent) + End If + Else + InsertPlaceholder(sFoundContent) + End If + Next i + If bDBFields Then + 'Open the DB beamer with the right DB + Dim oDisp as Object + Dim oTransformer + Dim aURL as new com.sun.star.util.URL + aURL.complete = ".component:DB/DataSourceBrowser" + oTransformer = createUnoService("com.sun.star.util.URLTransformer") + oTransformer.parseStrict(aURL) + oDisp = oDocument.getCurrentController.getFrame.queryDispatch(aURL, "_beamer", com.sun.star.frame.FrameSearchFlag.CHILDREN + com.sun.star.frame.FrameSearchFlag.CREATE) + Dim aArgs(3) as new com.sun.star.beans.PropertyValue + aArgs(1).Name = "DataSourceName" + aArgs(1).Value = sAddressbook + aArgs(2).Name = "CommandType" + aArgs(2).Value = com.sun.star.sdb.CommandType.TABLE + aArgs(3).Name = "Command" + aArgs(3).Value = Table + oDisp.dispatch(aURL, aArgs()) + End If + + GENERALERROR: + If Err <> 0 Then + Msgbox(msgError$,16, GetProductName()) + Resume LETSGO + End If + LETSGO: + +End Sub + + +Sub InsertDBField(sDBName as String, sTableName as String, sColName as String) +Dim oFieldMaster, oField as Object + If sColname <> "" Then + oFieldMaster = oDocument.createInstance("com.sun.star.text.FieldMaster.Database") + oField = oDocument.createInstance("com.sun.star.text.TextField.Database") + oFieldMaster.DataBaseName = sDBName + oFieldMaster.DataBaseName = sDBName + oFieldMaster.DataTableName = sTableName + oFieldMaster.DataColumnName = sColName + oField.AttachTextfieldmaster (oFieldMaster) + oBookText.InsertTextContent(oBookMarkCursor, oField, True) + oField.Content = "<" & sColName & ">" + End If +End Sub + + +Sub InsertPlaceholder(sColName as String) +Dim oFieldMaster as Object +Dim bCorrectField as Boolean + If sColname <> "" Then + bCorrectField = True + oFieldMaster = oDocument.createInstance("com.sun.star.text.TextField.JumpEdit") + Select Case sColName + Case "Company" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_1") + Case "Department" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_2") + Case "FirstName" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_3") + Case "LastName" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_4") + Case "Street" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_5") + Case "Country" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_6") + Case "Zip" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_7") + Case "City" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_8") + Case "Title" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_9") + Case "Position" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_10") + Case "AddrForm" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_11") + Case "Code" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_12") + Case "AddrFormMail" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_13") + Case "PhonePriv" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_14") + Case "PhoneComp" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_15") + Case "Fax" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_16") + Case "EMail" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_17") + Case "URL" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_18") + Case "Note" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_19") + Case "Altfield1" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_20") + Case "Altfield2" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_21") + Case "Altfield3" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_22") + Case "Altfield4" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_23") + Case "Id" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_24") + Case "State" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_25") + Case "PhoneOffice" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_26") + Case "Pager" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_27") + Case "PhoneCell" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_28") + Case "PhoneOther" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_29") + Case "CalendarURL" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_30") + Case "InviteParticipant" + oFieldMaster.PlaceHolder = getResText("CorrespondenceFields_31") + Case Else + bCorrectField = False + End Select + If bCorrectField Then + oFieldMaster.Hint = getResText("CorrespondenceFields_0") + oBookText.InsertTextContent(oBookMarkCursor, oFieldMaster, True) + End If + End If +End Sub + diff --git a/wizards/source/template/DialogStyles.xdl b/wizards/source/template/DialogStyles.xdl new file mode 100644 index 000000000..ec5f71423 --- /dev/null +++ b/wizards/source/template/DialogStyles.xdl @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/template/ModuleAgenda.xba b/wizards/source/template/ModuleAgenda.xba new file mode 100644 index 000000000..a17fb68cd --- /dev/null +++ b/wizards/source/template/ModuleAgenda.xba @@ -0,0 +1,220 @@ + + + +' All variables must be declared before use +Option Explicit + +' Used for "disabling" the cancel button of the dialog +Public DialogExited As Boolean +Dim DlgAgenda_gMyName as String +Public TemplateDialog as Object +Public DialogModel as Object +Public sTrueContent as String +Public Bookmarkname as String + + + +Sub Initialize() +' User sets the type of minutes + BasicLibraries.LoadLibrary( "Tools" ) + TemplateDialog = LoadDialog("Template", "TemplateDialog") + DialogModel = TemplateDialog.Model + DialogModel.Step = 1 + LoadLanguageAgenda() + DialogModel.OptAgenda2.State = TRUE + GetOptionValues() + DialogExited = FALSE + TemplateDialog.Execute +End Sub + + +Sub LoadLanguageAgenda() + If InitResources("'Template'") Then + DlgAgenda_gMyName = GetResText("AgendaDlgName") + DialogModel.CmdCancel.Label = GetResText("STYLES_2") + DialogModel.CmdAgdGoon.Label = GetResText("STYLES_3") +' DlgAgenda_gMsgNoCancel$ = GetResText("AgendaDlgNoCancel") + DialogModel.FrmAgenda.Label = GetResText("AgendaDlgFrame") + DialogModel.OptAgenda1.Label = GetResText("AgendaDlgButton1") + DialogModel.OptAgenda2.Label = GetResText("AgendaDlgButton2") +' DialogModel.OptAgenda1.State = 1 + End If +End Sub + + +Sub ModifyTemplate() +Dim oDocument, oBookmarks, oBookmark, oBookmarkCursor, oTextField as Object +Dim i as Integer + + oDocument = ThisComponent + oBookMarks = oDocument.Bookmarks + + On Local Error Goto NOBOOKMARK + TemplateDialog.EndExecute + DialogExited = TRUE + oBookmarkCursor = CreateBookmarkCursor(oDocument, BookmarkName) + oBookmarkCursor.Text.insertString(oBookmarkCursor,"",True) + ' Delete all the Bookmarks except for the one named "NextTopic" + For i = oBookmarks.Count-1 To 0 Step -1 + oBookMark = oBookMarks.GetByIndex(i) + If oBookMark.Name <> "NextTopic" Then + oBookMark.Dispose() + End If + Next i + oBookMarkCursor = CreateBookmarkCursor(oDocument, "NextTopic") + If Not IsNull(oBookMarkCursor) Then + oTextField = oBookMarkCursor.TextField +' oTextField.TrueContent = sTrueContent + oTextField.Content = sTrueContent + End If + + NOBOOKMARK: + If Err <> 0 Then + RESUME NEXT + End If +End Sub + + +Sub NewTopic +' Add a new topic to the agenda +Dim oDocument, oBookmarks, oBookmark, oBookmarkCursor, oTextField as Object +Dim oBaustein, oAutoText, oAutoGroup as Object +Dim i as Integer + + oDocument = ThisComponent + oBookMarkCursor = CreateBookMarkCursor(oDocument, "NextTopic") + oTextField = oBookMarkCursor.TextField + oAutoText = CreateUnoService("com.sun.star.text.AutoTextContainer") + If oAutoText.HasbyName("template") Then + oAutoGroup = oAutoText.GetbyName("template") + If oAutoGroup.HasbyName(oTextField.Content) Then + oBaustein = oAutoGroup.GetbyName(oTextField.Content) + oBaustein.ApplyTo(oBookMarkCursor) + Else + Msgbox("AutoText '" & oTextField.Content & "' is not existing. Cannot insert additional topic!") + End If + Else + Msgbox("AutoGroupField template is not existing. Cannot insert additional topic!", 16, DlgAgenda_gMyName ) + End If +End Sub + + + +' Add initials, date and time at bottom of agenda, disable and hide command buttons +Sub FinishAgenda +Dim BtnAddAgendaTopic As Object +Dim BtnFinishAgenda As Object +Dim oUserField, oDateTimeField as Object +Dim oBookmarkCursor as Object +Dim oFormats, oLocale as Object +Dim iDateTimeKey as Integer + + BasicLibraries.LoadLibrary( "Tools" ) + oDocument = ThisComponent + + oUserField = oDocument.CreateInstance("com.sun.star.text.TextField.ExtendedUser") + oUserField.UserDatatype = com.sun.star.text.UserDataPart.SHORTCUT + + oDateTimeField = oDocument.CreateInstance("com.sun.star.text.TextField.DateTime") + + ' Assign Standardformat to Datetime-Textfield + oFormats = oDocument.Numberformats + oLocale = oDocument.CharLocale + iDateTimeKey = oFormats.GetStandardFormat(com.sun.star.util.NumberFormat.DATETIME,oLocale) + oDateTimeField.NumberFormat = iDateTimeKey + + oBookmarkCursor = CreateBookmarkCursor(oDocument, "NextTopic") + oBookmarkCursor.Text.InsertTextContent(oBookmarkCursor,oUserField,False) + oBookmarkCursor.Text.InsertString(oBookmarkCursor," ",False) + oBookmarkCursor.Text.InsertTextContent(oBookmarkCursor,oDateTimeField,False) + BtnAddAgendaTopic = getControlModel(oDocument, "BtnAddAgendaTopic") + BtnFinishAgenda = getControlModel(oDocument, "BtnFinishAgenda") + If Not IsNull(BtnAddAgendaTopic) Then BtnAddAgendaTopic.Enabled = FALSE + If Not IsNull(BtnFinishAgenda) Then BtnFinishAgenda.Enabled = FALSE +End Sub + + +Function CreateBookMarkCursor(oDocument as Object,sBookmarkName as String) + oBookMarks = oDocument.Bookmarks + If oBookmarks.HasbyName(sBookmarkName) Then + oBookMark = oBookMarks.GetbyName(sBookmarkName) + CreateBookMarkCursor = oBookMark.Anchor.Text.CreateTextCursorByRange(oBookMark.Anchor) + Else + Msgbox "Bookmark " & sBookmarkName & " is not defined!" + End If +End Function + + + +Sub DeleteButtons +Dim AgendaFinished As Boolean +Dim BtnAddAgendaTopic As Object +Dim BtnFinishAgenda As Object + + oDocument = ThisComponent + + BtnAddAgendaTopic = getControlModel(oDocument, "BtnAddAgendaTopic") + BtnFinishAgenda = getControlModel(oDocument, "BtnFinishAgenda") + + ' If buttons could be accessed: If at least one button is disabled, then agenda is finished + AgendaFinished = FALSE + If Not IsNull(BtnAddAgendaTopic) Then + AgendaFinished = (AgendaFinished Or (BtnAddAgendaTopic.Enabled = FALSE)) + End If + + If Not IsNull(BtnFinishAgenda) Then + AgendaFinished = (AgendaFinished Or (BtnFinishAgenda.Enabled = FALSE)) + End If + + ' Delete Buttons, empty rows at end of document & macro bindings if agenda is finished + If AgendaFinished Then + DisposeControl(oDocument, "BtnAddAgendaTopic") + DisposeControl(oDocument, "BtnFinishAgenda") + + oBookmarkCursor = CreateBookMarkCursor(oDocument,"NextTopic") + oBookMarkCursor.GotoEnd(True) + oBookmarkCursor.Text.insertString(oBookmarkCursor,"",True) + + AttachBasicMacroToEvent(oDocument,"OnNew", "") + AttachBasicMacroToEvent(oDocument,"OnSave", "") + AttachBasicMacroToEvent(oDocument,"OnSaveAs", "") + AttachBasicMacroToEvent(oDocument,"OnPrint", "") + End If +End Sub + + + +Sub GetOptionValues(Optional aEvent as Object) +Dim CurTag as String +Dim Taglist() as String + If Not IsMissing(aEvent) Then + CurTag = aEvent.Source.Model.Tag + Else + If DialogModel.OptAgenda1.State = TRUE Then + CurTag = DialogModel.OptAgenda1.Tag + Else + CurTag = DialogModel.OptAgenda2.Tag + End If + End If + Taglist() = ArrayoutOfString(CurTag, ";") + Bookmarkname = TagList(0) + sTrueContent = TagList(1) +End Sub + + diff --git a/wizards/source/template/Samples.xba b/wizards/source/template/Samples.xba new file mode 100644 index 000000000..25ff81bcf --- /dev/null +++ b/wizards/source/template/Samples.xba @@ -0,0 +1,168 @@ + + + +Option Explicit + +Const NumStyles = 18 +Const aTempFileName = "Berend_Ilko_Tom_Stella_Volker.stc" +Dim oUcbObject as Object +Public StylesDir as String +Public StylesDialog as Object +Public PathSeparator as String +Public oFamilies as Object +Public aOptions(0) as New com.sun.star.beans.PropertyValue +Public sQueryPath as String +Public NoArgs()as New com.sun.star.beans.PropertyValue +Public aTempURL as String + +Public Files(100) as String + +'-------------------------------------------------------------------------------------- +'Calc Style Section starts here + +Sub ShowStyles +'This sub displays the style selection dialog if the current document is a calc document. +Dim TemplateDir, ActFileTitle, DisplayDummy as String +Dim sFilterName(0) as String +Dim StyleNames() as String +Dim LocalizedStyleNames(NumStyles,2) As String +Dim LocalizedStyleName As String +Dim t as Integer +Dim MaxIndex as Integer +Dim StyleNameDef As Variant + BasicLibraries.LoadLibrary("Tools") + If InitResources("'Template'") then + oDocument = ThisComponent + If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then + ToggleWindow(False) + oUcbObject = createUnoService("com.sun.star.ucb.SimpleFileAccess") + oFamilies = oDocument.StyleFamilies + SaveCurrentStyles(oDocument) + StylesDialog = LoadDialog("Template", "DialogStyles") + DialogModel = StylesDialog.Model + TemplateDir = GetPathSettings("Template", False, 0) + StylesDir = GetOfficeSubPath("Template", "wizard/styles/") + sQueryPath = GetOfficeSubPath("Template", "../wizard/bitmap/") + DialogModel.Title = GetResText("STYLES_0") + DialogModel.cmdCancel.Label = GetResText("STYLES_2") + DialogModel.cmdOk.Label = GetResText("STYLES_3") + StyleNameDef = Array("(Standard)", "Autumn Leaves", "Be", "Black and White", "Blackberry Bush", "Blue Jeans", "Fifties Diner", "Glacier", "Green Grapes", "Marine", "Millennium", "Nature", "Neon", "Night", "PC Nostalgia", "Pastel", "Pool Party", "Pumpkin") + For t = 0 to NumStyles - 1 + LocalizedStyleNames(t,0) = StyleNameDef(t) + LocalizedStyleNames(t,1) = GetResText("STYLENAME_" & Trim(Str(t))) + Next t + Stylenames() = ReadDirectories(StylesDir, False, False, True,) + MaxIndex = Ubound(Stylenames()) + For t = 0 to MaxIndex + LocalizedStyleName = StringInMultiArray(LocalizedStyleNames(), StyleNames(t,1), 0, 1) + If LocalizedStyleName <> "" Then + StyleNames(t,1) = LocalizedStyleName + End If + Next t + BubbleSortList(Stylenames(),True) + Dim cStyles(MaxIndex) + For t = 0 to MaxIndex + Files(t) = StyleNames(t,0) + cStyles(t) = StyleNames(t,1) + Next t + On Local Error Resume Next + DialogModel.lbStyles.StringItemList() = cStyles() + ToggleWindow(True) + StylesDialog.Execute + End If + End If +End Sub + + +Sub SelectStyle +'This sub loads the specific styles from a style document and loads them into the +'current document. +Dim StylePath as String +Dim NewStyle as String +Dim Position as Integer + Position = DialogModel.lbStyles.SelectedItems(0) + If Position > -1 Then + ToggleWindow(False) + StylePath = Files(Position) + aOptions(0).Name = "OverwriteStyles" + aOptions(0).Value = true + oFamilies.loadStylesFromURL(StylePath, aOptions()) + ToggleWindow(True) + End If +End Sub + + +Sub SaveCurrentStyles(oDocument as Object) +'This sub stores the current document in the directory to hold temporary files. + On Error Goto ErrorOccurred + aTempURL = GetPathSettings("Temp", False) + Dim aRightMost as String + aRightMost = Right(aTempURL, 1) + if aRightMost = "/" Then + aTempURL = aTempURL & aTempFileName + Else + aTempURL = aTempURL & "/" & aTempFileName + End If + + While FileExists(aTempURL) + aTempURL=Left(aTempURL,(Len(aTempURL)-4)) & "_1.stc" + Wend + oDocument.storeToURL(aTempURL, NoArgs()) + Exit Sub + +ErrorOccurred: + MsgBox(GetResText("STYLES_1"), 16, GetResText("STYLES_0")) + On Local Error Goto 0 +End Sub + + +Sub RestoreCurrentStyles +'This sub retrieves the styles from the temporarily save document + ToggleWindow(False) + On Local Error Goto NoFile + If FileExists(aTempURL) Then + aOptions(0).Name = "OverwriteStyles" + aOptions(0).Value = true + oFamilies.LoadStylesFromURL(aTempURL, aOptions()) + KillTempFile() + End If + StylesDialog.EndExecute + ToggleWindow(True) +NOFILE: + If Err <> 0 Then + Msgbox("Cannot load Document from " & aTempUrl, 64, GetProductname()) + End If + On Local Error Goto 0 +End Sub + + +Sub CloseStyleDialog + KillTempFile() + DialogExited = True + StylesDialog.Endexecute +End Sub + + +Sub KillTempFile() + If oUcbObject.Exists(aTempUrl) Then + oUcbObject.Kill(aTempUrl) + End If +End Sub + + diff --git a/wizards/source/template/TemplateDialog.xdl b/wizards/source/template/TemplateDialog.xdl new file mode 100644 index 000000000..545b92f95 --- /dev/null +++ b/wizards/source/template/TemplateDialog.xdl @@ -0,0 +1,46 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/template/dialog.xlb b/wizards/source/template/dialog.xlb new file mode 100644 index 000000000..c5eed37a2 --- /dev/null +++ b/wizards/source/template/dialog.xlb @@ -0,0 +1,7 @@ + + + + + + + diff --git a/wizards/source/template/script.xlb b/wizards/source/template/script.xlb new file mode 100644 index 000000000..c89cc3788 --- /dev/null +++ b/wizards/source/template/script.xlb @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/wizards/source/tools/Debug.xba b/wizards/source/tools/Debug.xba new file mode 100644 index 000000000..fe909c5b8 --- /dev/null +++ b/wizards/source/tools/Debug.xba @@ -0,0 +1,253 @@ + + + +REM ***** BASIC ***** + +Sub ActivateReadOnlyFlag() + SetBasicReadOnlyFlag(True) +End Sub + + +Sub DeactivateReadOnlyFlag() + SetBasicReadOnlyFlag(False) +End Sub + + +Sub SetBasicReadOnlyFlag(bReadOnly as Boolean) +Dim i as Integer +Dim LibName as String +Dim BasicLibNames() as String + BasicLibNames() = BasicLibraries.ElementNames() + For i = 0 To Ubound(BasicLibNames()) + LibName = BasicLibNames(i) + If LibName <> "Standard" Then + BasicLibraries.SetLibraryReadOnly(LibName, bReadOnly) + End If + Next i +End Sub + + +Sub WritedbgInfo(LocObject as Object) +Dim locUrl as String +Dim oLocDocument as Object +Dim oLocText as Object +Dim oLocCursor as Object +Dim NoArgs() +Dim sObjectStrings(2) as String +Dim sProperties() as String +Dim n as Integer +Dim m as Integer +Dim MaxIndex as Integer + sObjectStrings(0) = LocObject.dbg_Properties + sObjectStrings(1) = LocObject.dbg_Methods + sObjectStrings(2) = LocObject.dbg_SupportedInterfaces + LocUrl = "private:factory/swriter" + oLocDocument = StarDesktop.LoadComponentFromURL(LocUrl,"_default",0,NoArgs) + oLocText = oLocDocument.text + oLocCursor = oLocText.createTextCursor() + oLocCursor.gotoStart(False) + If Vartype(LocObject) = 9 then ' an Object Variable + For n = 0 To 2 + sProperties() = ArrayoutofString(sObjectStrings(n),";", MaxIndex) + For m = 0 To MaxIndex + oLocText.insertString(oLocCursor,sProperties(m),False) + oLocText.insertControlCharacter(oLocCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) + Next m + Next n + Elseif Vartype(LocObject) = 8 Then ' a String Variable + oLocText.insertString(oLocCursor,LocObject,False) + ElseIf Vartype(LocObject) = 1 Then + Msgbox("Variable is Null!", 16, GetProductName()) + End If +End Sub + + +Sub WriteDbgString(LocString as string) +Dim oLocDesktop as object +Dim LocUrl as String +Dim oLocDocument as Object +Dim oLocCursor as Object +Dim oLocText as Object + + LocUrl = "private:factory/swriter" + oLocDocument = StarDesktop.LoadComponentFromURL(LocUrl,"_default",0,NoArgs) + oLocText = oLocDocument.text + oLocCursor = oLocText.createTextCursor() + oLocCursor.gotoStart(False) + oLocText.insertString(oLocCursor,LocString,False) +End Sub + + +Sub printdbgInfo(LocObject) + If Vartype(LocObject) = 9 then + Msgbox LocObject.dbg_properties + Msgbox LocObject.dbg_methods + Msgbox LocObject.dbg_supportedinterfaces + Elseif Vartype(LocObject) = 8 Then ' a String Variable + Msgbox LocObject + ElseIf Vartype(LocObject) = 0 Then + Msgbox("Variable is Null!", 16, GetProductName()) + Else + Msgbox("Type of Variable: " & Typename(LocObject), 48, GetProductName()) + End If +End Sub + + +Sub ShowArray(LocArray()) +Dim i as integer +Dim msgstring + msgstring = "" + For i = Lbound(LocArray()) to Ubound(LocArray()) + msgstring = msgstring + LocArray(i) + chr(13) + Next + Msgbox msgstring +End Sub + + +Sub ShowPropertyValues(oLocObject as Object) +Dim PropName as String +Dim sValues as String + On Local Error Goto NOPROPERTYSETINFO: + sValues = "" + For i = 0 To Ubound(oLocObject.PropertySetInfo.Properties) + Propname = oLocObject.PropertySetInfo.Properties(i).Name + sValues = sValues & PropName & chr(13) & " = " & oLocObject.GetPropertyValue(PropName) & chr(13) + Next i + Msgbox(sValues , 64, GetProductName()) + Exit Sub + +NOPROPERTYSETINFO: + Msgbox("Sorry, No PropertySetInfo attached to the object", 16, GetProductName()) + Resume LEAVEPROC + LEAVEPROC: +End Sub + + +Sub ShowNameValuePair(Pair()) +Dim i as Integer +Dim ShowString as String + ShowString = "" + On Local Error Resume Next + For i = 0 To Ubound(Pair()) + ShowString = ShowString & Pair(i).Name & " = " + ShowString = ShowString & Pair(i).Value & chr(13) + Next i + Msgbox ShowString +End Sub + + +' Retrieves all the Elements of aSequence of an object, with the +' possibility to define a filter(sfilter <> "") +Sub ShowElementNames(oLocElements() as Object, Optional sFiltername as String) +Dim i as Integer +Dim NameString as String + NameString = "" + For i = 0 To Ubound(oLocElements()) + If Not IsMissIng(sFilterName) Then + If Instr(1, oLocElements(i), sFilterName) Then + NameString = NameString & oLocElements(i) & chr(13) + End If + Else + NameString = NameString & oLocElements(i) & chr(13) + End If + Next i + Msgbox(NameString, 64, GetProductName()) +End Sub + + +' Retrieves all the supported servicenames of an object, with the +' possibility to define a filter(sfilter <> "") +Sub ShowSupportedServiceNames(oLocObject as Object, Optional sFilterName as String) + On Local Error Goto NOSERVICENAMES + If IsMissing(sFilterName) Then + ShowElementNames(oLocobject.SupportedServiceNames()) + Else + ShowElementNames(oLocobject.SupportedServiceNames(), sFilterName) + End If + Exit Sub + + NOSERVICENAMES: + Msgbox("Sorry, No 'SupportedServiceNames' - Property attached to the object", 16, GetProductName()) + Resume LEAVEPROC + LEAVEPROC: +End Sub + + +' Retrieves all the available Servicenames of an object, with the +' possibility to define a filter(sfilter <> "") +Sub ShowAvailableServiceNames(oLocObject as Object, Optional sFilterName as String) + On Local Error Goto NOSERVICENAMES + If IsMissing(sFilterName) Then + ShowElementNames(oLocobject.AvailableServiceNames) + Else + ShowElementNames(oLocobject.AvailableServiceNames, sFilterName) + End If + Exit Sub + + NOSERVICENAMES: + Msgbox("Sorry, No 'AvailableServiceNames' - Property attached to the object", 16, GetProductName()) + Resume LEAVEPROC + LEAVEPROC: +End Sub + + +Sub ShowCommands(oLocObject as Object) + On Local Error Goto NOCOMMANDS + ShowElementNames(oLocObject.QueryCommands) + Exit Sub + NOCOMMANDS: + Msgbox("Sorry, No 'QueryCommands' - Property attached to the object", 16, GetProductName()) + Resume LEAVEPROC + LEAVEPROC: +End Sub + + +Sub ProtectCurrentSheets() +Dim oDocument as Object +Dim sDocType as String +Dim iResult as Integer +Dim oSheets as Object +Dim i as Integer +Dim bDoProtect as Boolean + oDocument = StarDesktop.ActiveFrame.Controller.Model + sDocType = GetDocumentType(oDocument) + If sDocType = "scalc" Then + oSheets = oDocument.Sheets + bDoProtect = False + For i = 0 To oSheets.Count-1 + If Not oSheets(i).IsProtected Then + bDoProtect = True + End If + Next i + If bDoProtect Then + iResult = Msgbox( "Do you want to protect all sheets of this document?",35, GetProductName()) + If iResult = 6 Then + ProtectSheets(oDocument.Sheets) + End If + End If + End If +End Sub + + +Sub FillDocument() + oMyReport = createUNOService("com.sun.star.wizards.report.CallReportWizard") + oMyReport.trigger("fill") +End Sub + + \ No newline at end of file diff --git a/wizards/source/tools/DlgOverwriteAll.xdl b/wizards/source/tools/DlgOverwriteAll.xdl new file mode 100644 index 000000000..b241a9bcc --- /dev/null +++ b/wizards/source/tools/DlgOverwriteAll.xdl @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + + + + diff --git a/wizards/source/tools/Listbox.xba b/wizards/source/tools/Listbox.xba new file mode 100644 index 000000000..21f8f44c6 --- /dev/null +++ b/wizards/source/tools/Listbox.xba @@ -0,0 +1,370 @@ + + + +Option Explicit +Dim OriginalList() +Dim oDialogModel as Object + + +Sub MergeList(SourceListBox() as Object, SecondList() as String) +Dim i as Integer +Dim MaxIndex as Integer + MaxIndex = Ubound(SecondList()) + OriginalList() = AddListToList(OriginalList(), SecondList()) + For i = 0 To MaxIndex + SourceListbox = AddSingleItemToListbox(SourceListbox, SecondList(i)) + Next i + Call FormSetMoveRights() +End Sub + + +Sub RemoveListItems(SourceListbox as Object, TargetListbox as Object, RemoveList() as String) +Dim i as Integer +Dim s as Integer +Dim MaxIndex as Integer +Dim CopyList() + MaxIndex = Ubound(RemoveList()) + For i = 0 To MaxIndex + RemoveListboxItemByName(SourceListbox, RemoveList(i)) + RemoveListboxItemByName(TargetListbox, RemoveList(i)) + Next i + CopyList() = OriginalList() + s = 0 + MaxIndex = Ubound(CopyList()) + For i = 0 To MaxIndex + If IndexInArray(CopyList(i),RemoveList())= -1 Then + OriginalList(s) = CopyList(i) + s = s + 1 + End If + Next i + ReDim Preserve OriginalList(s-1) + Call FormSetMoveRights() +End Sub + + +' Note Boolean Parameter +Sub InitializeListboxProcedures(oModel as Object, SourceListbox as Object, TargetListbox as Object) +Dim EmptyList() + Set oDialogModel = oModel + OriginalList()= SourceListbox.StringItemList() + TargetListbox.StringItemList() = EmptyList() +End Sub + + +Sub CopyListboxItems(SourceListbox as Object, TargetListbox As Object) +Dim NullArray() + TargetListbox.StringItemList() = OriginalList() + SourceListbox.StringItemList() = NullArray() +End Sub + + +Sub FormMoveSelected() + Call MoveSelectedListBox(oDialogModel.lstFields, oDialogModel.lstSelFields) + Call FormSetMoveRights() + oDialogModel.lstSelFields.Tag = True +End Sub + + +Sub FormMoveAll() + Call CopyListboxItems(oDialogModel.lstFields, oDialogModel.lstSelFields) + Call FormSetMoveRights() + oDialogModel.lstSelFields.Tag = True +End Sub + + +Sub FormRemoveSelected() + Call MoveOrderedSelectedListbox(oDialogModel.lstFields, oDialogModel.lstSelFields, False) + Call FormSetMoveRights() + oDialogModel.lstSelFields.Tag = True +End Sub + + +Sub FormRemoveAll() + Call MoveOrderedSelectedListbox(oDialogModel.lstFields, oDialogModel.lstSelFields, True) + Call FormSetMoveRights() + oDialogModel.lstSelFields.Tag = 1 +End Sub + + +Sub MoveSelectedListBox(SourceListbox as Object, TargetListbox as Object) +Dim MaxCurTarget as Integer +Dim MaxSourceSelected as Integer +Dim n as Integer +Dim m as Integer +Dim CurIndex +Dim iOldTargetSelect as Integer +Dim iOldSourceSelect as Integer + MaxCurTarget = Ubound(TargetListbox.StringItemList()) + MaxSourceSelected = Ubound(SourceListbox.SelectedItems()) + Dim TargetList(MaxCurTarget+MaxSourceSelected+1) + If MaxSourceSelected > -1 Then + iOldSourceSelect = SourceListbox.SelectedItems(0) + If Ubound(TargetListbox.SelectedItems()) > -1 Then + iOldTargetSelect = TargetListbox.SelectedItems(0) + Else + iOldTargetSelect = -1 + End If + For n = 0 To MaxCurTarget + TargetList(n) = TargetListbox.StringItemList(n) + Next n + For m = 0 To MaxSourceSelected + CurIndex = SourceListbox.SelectedItems(m) + TargetList(n) = SourceListbox.StringItemList(CurIndex) + n = n + 1 + Next m + TargetListBox.StringItemList() = TargetList() + SourceListbox.StringItemList() = RemoveSelected (SourceListbox) + SetNewSelection(SourceListbox, iOldSourceSelect) + SetNewSelection(TargetListbox, iOldTargetSelect) + End If +End Sub + + + +Sub MoveOrderedSelectedListbox(lstSource as Object, lstTarget as Object, bMoveAll as Boolean) +Dim NullArray() +Dim MaxSelected as Integer +Dim MaxSourceIndex as Integer +Dim MaxOriginalIndex as Integer +Dim MaxNewIndex as Integer +Dim n as Integer +Dim m as Integer +Dim CurIndex as Integer +Dim SearchString as String +Dim SourceList() as String +Dim iOldTargetSelect as Integer +Dim iOldSourceSelect as Integer + If bMoveAll Then + lstSource.StringItemList() = OriginalList() + lstTarget.StringItemList() = NullArray() + Else + MaxOriginalIndex = Ubound(OriginalList()) + MaxSelected = Ubound(lstTarget.SelectedItems()) + iOldTargetSelect = lstTarget.SelectedItems(0) + If Ubound(lstSource.SelectedItems()) > -1 Then + iOldSourceSelect = lstSource.SelectedItems(0) + End If + Dim SelList(MaxSelected) + For n = 0 To MaxSelected + CurIndex = lstTarget.SelectedItems(n) + SelList(n) = lstTarget.StringItemList(CurIndex) + Next n + SourceList() = lstSource.StringItemList() + MaxSourceIndex = Ubound(lstSource.StringItemList()) + MaxNewIndex = MaxSelected + MaxSourceIndex + 1 + Dim NewSourceList(MaxNewIndex) + m = 0 + For n = 0 To MaxOriginalIndex + SearchString = OriginalList(n) + If IndexInArray(SearchString, SelList()) <> -1 Then + NewSourceList(m) = SearchString + m = m + 1 + ElseIf IndexInArray(SearchString, SourceList()) <> -1 Then + NewSourceList(m) = SearchString + m = m + 1 + End If + Next n + lstSource.StringItemList() = NewSourceList() + lstTarget.StringItemList() = RemoveSelected(lstTarget) + End If + SetNewSelection(lstSource, iOldSourceSelect) + SetNewSelection(lstTarget, iOldTargetSelect) + +End Sub + + +Function RemoveSelected(oListbox as Object) +Dim MaxIndex as Integer +Dim MaxSelected as Integer +Dim n as Integer +Dim m as Integer +Dim CurIndex as Integer +Dim CurItem as String +Dim ResultArray() + MaxIndex = Ubound(oListbox.StringItemList()) + MaxSelected = Ubound(oListbox.SelectedItems()) + Dim LocItemList(MaxIndex) + LocItemList() = oListbox.StringItemList() + If MaxSelected > -1 Then + For n = 0 To MaxSelected + CurIndex = oListbox.SelectedItems(n) + LocItemList(CurIndex) = "" + Next n + If MaxIndex > 0 Then + ReDim ResultArray(MaxIndex - MaxSelected - 1) + m = 0 + For n = 0 To MaxIndex + CurItem = LocItemList(n) + If CurItem <> "" Then + ResultArray(m) = CurItem + m = m + 1 + End If + Next n + End If + RemoveSelected = ResultArray() + Else + RemoveSelected = oListbox.StringItemList() + End If +End Function + + +Sub SetNewSelection(oListBox as Object, iLastSelection as Integer) +Dim MaxIndex as Integer +Dim SelIndex as Integer +Dim SelList(0) as Integer + MaxIndex = Ubound(oListBox.StringItemList()) + If MaxIndex > -1 AND iLastSelection > -1 Then + If iLastSelection > MaxIndex Then + Selindex = MaxIndex + Else + SelIndex = iLastSelection + End If + Sellist(0) = SelIndex + oListBox.SelectedItems() = SelList() + End If +End Sub + + +Sub ToggleListboxControls(oDialogModel as Object, bDoEnable as Boolean) + With oDialogModel + .lblFields.Enabled = bDoEnable + .lblSelFields.Enabled = bDoEnable +' .lstTables.Enabled = bDoEnable + .lstFields.Enabled = bDoEnable + .lstSelFields.Enabled = bDoEnable + .cmdRemoveAll.Enabled = bDoEnable + .cmdRemoveSelected.Enabled = bDoEnable + .cmdMoveAll.Enabled = bDoEnable + .cmdMoveSelected.Enabled = bDoEnable + End With + If bDoEnable Then + FormSetMoveRights() + End If +End Sub + + +' Enable or disable the buttons used for moving the available +' fields between the two list boxes. +Sub FormSetMoveRights() +Dim bIsFieldSelected as Boolean +Dim bSelectSelected as Boolean +Dim FieldCount as Integer +Dim SelectCount as Integer + bIsFieldSelected = Ubound(oDialogModel.lstFields.SelectedItems()) <> -1 + FieldCount = Ubound(oDialogModel.lstFields.StringItemList()) + 1 + bSelectSelected = Ubound(oDialogModel.lstSelFields.SelectedItems()) > -1 + SelectCount = Ubound(oDialogModel.lstSelFields.StringItemList()) + 1 + oDialogModel.cmdRemoveAll.Enabled = SelectCount>=1 + oDialogModel.cmdRemoveSelected.Enabled = bSelectSelected + oDialogModel.cmdMoveAll.Enabled = FieldCount >=1 + oDialogModel.cmdMoveSelected.Enabled = bIsFieldSelected + oDialogModel.cmdGoOn.Enabled = SelectCount>=1 + ' This flag is set to '1' when the lstSelFields has been modified +End Sub + + +Function AddSingleItemToListbox(ByVal oListbox as Object, ListItem as String, Optional iSelIndex) as Object +Dim MaxIndex as Integer +Dim i as Integer + + MaxIndex = Ubound(oListbox.StringItemList()) +Dim LocList(MaxIndex + 1) +' Todo: This goes faster with the Redim LocList(MaxIndex + 1) Preserve function + For i = 0 To MaxIndex + LocList(i) = oListbox.StringItemList(i) + Next i + LocList(MaxIndex + 1) = ListItem + oListbox.StringItemList() = LocList() + If Not IsMissing(iSelIndex) Then + SelectListboxItem(oListbox, iSelIndex) + End If + AddSingleItemToListbox() = oListbox +End Function + + +Sub EmptyListbox(oListbox as Object) +Dim NullList() as String + oListbox.StringItemList() = NullList() +End Sub + + +Sub SelectListboxItem(oListbox as Object, iSelIndex as Integer) +Dim LocSelList(0) as Integer + If iSelIndex <> -1 Then + LocSelList(0) = iSelIndex + oListbox.SelectedItems() = LocSelList() + End If +End Sub + + +Function GetSelectedListboxItems(oListbox as Object) +Dim SelList(Ubound(oListBox.SelectedItems())) as String +Dim i as Integer +Dim CurIndex as Integer + For i = 0 To Ubound(oListbox.SelectedItems()) + CurIndex = oListbox.SelectedItems(i) + SelList(i) = oListbox.StringItemList(CurIndex) + Next i + GetSelectedListboxItems() = SelList() +End Function + + +' Note: When using this Sub it must be ensured that the +' 'RemoveItem' appears only once in the Listbox +Sub RemoveListboxItemByName(oListbox as Object, RemoveItem as String) +Dim OldList() as String +Dim NullList() as String +Dim i as Integer +Dim a as Integer +Dim MaxIndex as Integer + OldList = oListbox.StringItemList() + MaxIndex = Ubound(OldList()) + If IndexInArray(RemoveItem, OldList()) <> -1 Then + If MaxIndex > 0 Then + a = 0 + Dim NewList(MaxIndex -1) + For i = 0 To MaxIndex + If RemoveItem <> OldList(i) Then + NewList(a) = OldList(i) + a = a + 1 + End If + Next i + oListbox.StringItemList() = NewList() + Else + oListBox.StringItemList() = NullList() + End If + End If +End Sub + + +Function GetItemPos(oListBox as Object, sItem as String) +Dim ItemList() +Dim MaxIndex as Integer +Dim i as Integer + ItemList() = oListBox.StringItemList() + MaxIndex = Ubound(ItemList()) + For i = 0 To MaxIndex + If sItem = ItemList(i) Then + GetItemPos() = i + Exit Function + End If + Next i + GetItemPos() = -1 +End Function + diff --git a/wizards/source/tools/Misc.xba b/wizards/source/tools/Misc.xba new file mode 100644 index 000000000..9aa6d2e2f --- /dev/null +++ b/wizards/source/tools/Misc.xba @@ -0,0 +1,834 @@ + + + +REM ***** BASIC ***** + +Const SBSHARE = 0 +Const SBUSER = 1 +Dim Taskindex as Integer +Dim oResSrv as Object + +Sub Main() +Dim PropList(3,1)' as String + PropList(0,0) = "URL" + PropList(0,1) = "sdbc:odbc:Erica_Test_Unicode" + PropList(1,0) = "User" + PropList(1,1) = "extra" + PropList(2,0) = "Password" + PropList(2,1) = "extra" + PropList(3,0) = "IsPasswordRequired" + PropList(3,1) = True +End Sub + + +Function RegisterNewDataSource(DSName as String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) +Dim oDataSource as Object +Dim oDBContext as Object +Dim oPropInfo as Object +Dim i as Integer + oDBContext = createUnoService("com.sun.star.sdb.DatabaseContext") + oDataSource = createUnoService("com.sun.star.sdb.DataSource") + For i = 0 To Ubound(PropertyList(), 1) + sPropName = PropertyList(i,0) + sPropValue = PropertyList(i,1) + oDataSource.SetPropertyValue(sPropName,sPropValue) + Next i + If Not IsMissing(DriverProperties()) Then + oDataSource.Info() = DriverProperties() + End If + oDBContext.RegisterObject(DSName, oDataSource) + RegisterNewDataSource () = oDataSource +End Function + + +' Connects to a registered Database +Function ConnectToDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) +Dim oDBContext as Object +Dim oDBSource as Object +' On Local Error Goto NOCONNECTION + oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + If oDBContext.HasbyName(DSName) Then + oDBSource = oDBContext.GetByName(DSName) + ConnectToDatabase = oDBSource.GetConnection(UserID, Password) + Else + If Not IsMissing(Propertylist()) Then + RegisterNewDataSource(DSName, PropertyList(), DriverProperties()) + oDBSource = oDBContext.GetByName(DSName) + ConnectToDatabase = oDBSource.GetConnection(UserID, Password) + Else + Msgbox("DataSource " & DSName & " is not registered" , 16, GetProductname()) + ConnectToDatabase() = NULL + End If + End If +NOCONNECTION: + If Err <> 0 Then + Msgbox(Error$, 16, GetProductName()) + Resume LEAVESUB + LEAVESUB: + End If +End Function + + +Function GetStarOfficeLocale() as New com.sun.star.lang.Locale +Dim aLocLocale As New com.sun.star.lang.Locale +Dim sLocale as String +Dim sLocaleList(1) +Dim oMasterKey + oMasterKey = GetRegistryKeyContent("org.openoffice.Setup/L10N/") + sLocale = oMasterKey.getByName("ooLocale") + sLocaleList() = ArrayoutofString(sLocale, "-") + aLocLocale.Language = sLocaleList(0) + If Ubound(sLocaleList()) > 0 Then + aLocLocale.Country = sLocaleList(1) + End If + If Ubound(sLocaleList()) > 1 Then + aLocLocale.Variant = sLocaleList(2) + End If + GetStarOfficeLocale() = aLocLocale +End Function + + +Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) +Dim oConfigProvider as Object +Dim aNodePath(0) as new com.sun.star.beans.PropertyValue + oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider") + aNodePath(0).Name = "nodepath" + aNodePath(0).Value = sKeyName + If IsMissing(bForUpdate) Then bForUpdate = False + If bForUpdate Then + GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath()) + Else + GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath()) + End If +End Function + + +Function GetProductname() as String +Dim oProdNameAccess as Object +Dim sVersion as String +Dim sProdName as String + oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product") + sProdName = oProdNameAccess.getByName("ooName") + sVersion = oProdNameAccess.getByName("ooSetupVersion") + GetProductName = sProdName & sVersion +End Function + + +' Opens a Document, checks beforehand, whether it has to be loaded +' or whether it is already on the desktop. +' If the parameter bDisposable is set to False then the returned document +' should not be disposed afterwards, because it is already opened. +Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean) +Dim oComponents as Object +Dim oComponent as Object + ' Search if one of the active Components is the one that you search for + oComponents = StarDesktop.Components.CreateEnumeration + While oComponents.HasmoreElements + oComponent = oComponents.NextElement + If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then + If UCase(oComponent.URL) = UCase(DocPath) then + OpenDocument() = oComponent + If Not IsMissing(bDisposable) Then + bDisposable = False + End If + Exit Function + End If + End If + Wend + If Not IsMissing(bDisposable) Then + bDisposable = True + End If + OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,"_default",0,Args()) +End Function + + +Function TaskonDesktop(DocPath as String) as Boolean +Dim oComponents as Object +Dim oComponent as Object + ' Search if one of the active Components is the one that you search for + oComponents = StarDesktop.Components.CreateEnumeration + While oComponents.HasmoreElements + oComponent = oComponents.NextElement + If hasUnoInterfaces(oComponent,"com.sun.star.frame.XModel") then + If UCase(oComponent.URL) = UCase(DocPath) then + TaskonDesktop = True + Exit Function + End If + End If + Wend + TaskonDesktop = False +End Function + + +' Retrieves a FileName out of a StarOffice-Document +Function RetrieveFileName(LocDoc as Object) +Dim LocURL as String +Dim LocURLArray() as String +Dim MaxArrIndex as integer + + LocURL = LocDoc.Url + LocURLArray() = ArrayoutofString(LocURL,"/",MaxArrIndex) + RetrieveFileName = LocURLArray(MaxArrIndex) +End Function + + +' Gets a special configured PathSetting +Function GetPathSettings(sPathType as String, Optional bshowall as Boolean, Optional ListIndex as integer) as String +Dim oSettings, oPathSettings as Object +Dim sPath as String +Dim PathList() as String +Dim MaxIndex as Integer +Dim oPS as Object + + oPS = createUnoService("com.sun.star.util.PathSettings") + + If Not IsMissing(bShowall) Then + If bShowAll Then + ShowPropertyValues(oPS) + Exit Function + End If + End If + sPath = oPS.getPropertyValue(sPathType) + If Not IsMissing(ListIndex) Then + ' Share and User-Directory + If Instr(1,sPath,";") <> 0 Then + PathList = ArrayoutofString(sPath,";", MaxIndex) + If ListIndex <= MaxIndex Then + sPath = PathList(ListIndex) + Else + Msgbox("String Cannot be analyzed!" & sPath , 16, GetProductName()) + End If + End If + End If + If Instr(1, sPath, ";") = 0 Then + GetPathSettings = ConvertToUrl(sPath) + Else + GetPathSettings = sPath + End If + +End Function + + + +' Gets the fully qualified path to a subdirectory of the +' Template Directory, e. g. with the parameter "wizard/bitmap" +' The parameter must be passed in Url notation +' The return-Value is in Url notation +Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String) +Dim sOfficeString as String +Dim sOfficeList() as String +Dim sOfficeDir as String +Dim sBigDir as String +Dim i as Integer +Dim MaxIndex as Integer +Dim oUcb as Object + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + sOfficeString = GetPathSettings(sOfficePath) + If Right(sSubDir,1) <> "/" Then + sSubDir = sSubDir & "/" + End If + sOfficeList() = ArrayoutofString(sOfficeString,";", MaxIndex) + For i = 0 To MaxIndex + sOfficeDir = ConvertToUrl(sOfficeList(i)) + If Right(sOfficeDir,1) <> "/" Then + sOfficeDir = sOfficeDir & "/" + End If + sBigDir = sOfficeDir & sSubDir + If oUcb.Exists(sBigDir) Then + GetOfficeSubPath() = sBigDir + Exit Function + End If + Next i + ShowNoOfficePathError() + GetOfficeSubPath = "" +End Function + + +Sub ShowNoOfficePathError() +Dim ProductName as String +Dim sError as String +Dim bResObjectexists as Boolean +Dim oLocResSrv as Object + bResObjectexists = not IsNull(oResSrv) + If bResObjectexists Then + oLocResSrv = oResSrv + End If + If InitResources("Tools") Then + ProductName = GetProductName() + sError = GetResText("RID_COMMON_6") + sError = ReplaceString(sError, ProductName, "%PRODUCTNAME") + sError = ReplaceString(sError, chr(13), "<BR>") + MsgBox(sError, 16, ProductName) + End If + If bResObjectexists Then + oResSrv = oLocResSrv + End If + +End Sub + + +Function InitResources(Description) as boolean +Dim xResource as Object +Dim sOfficeDir as String +Dim aArgs(5) as Any + On Error Goto ErrorOccurred + sOfficeDir = "$BRAND_BASE_DIR/$BRAND_SHARE_SUBDIR/wizards/" + sOfficeDir = GetDefaultContext.getByName("/singletons/com.sun.star.util.theMacroExpander").ExpandMacros(sOfficeDir) + aArgs(0) = sOfficeDir + aArgs(1) = true + aArgs(2) = GetStarOfficeLocale() + aArgs(3) = "resources" + aArgs(4) = "" + aArgs(5) = NULL + oResSrv = getProcessServiceManager().createInstanceWithArguments( "com.sun.star.resource.StringResourceWithLocation", aArgs() ) + If (IsNull(oResSrv)) then + InitResources = FALSE + MsgBox("could not initialize StringResourceWithLocation") + Else + InitResources = TRUE + End If + Exit Function +ErrorOccurred: + Dim nSolarVer + InitResources = FALSE + nSolarVer = GetSolarVersion() + MsgBox("Resource file missing", 16, GetProductName()) + Resume CLERROR + CLERROR: +End Function + + +Function GetResText( sID as String ) As string +Dim sString as String + On Error Goto ErrorOccurred + If Not IsNull(oResSrv) Then + sString = oResSrv.resolveString(sID) + GetResText = ReplaceString(sString, GetProductname(), "%PRODUCTNAME") + Else + GetResText = "" + End If + Exit Function +ErrorOccurred: + GetResText = "" + MsgBox("Resource with ID =" + sID + " not found!", 16, GetProductName()) + Resume CLERROR + CLERROR: +End Function + + +Function CutPathView(sDocUrl as String, Optional PathLen as Integer) +Dim sViewPath as String +Dim FileName as String +Dim iFileLen as Integer + sViewPath = ConvertfromURL(sDocURL) + iViewPathLen = Len(sViewPath) + If iViewPathLen > 60 Then + FileName = FileNameoutofPath(sViewPath, "/") + iFileLen = Len(FileName) + If iFileLen < 44 Then + sViewPath = Left(sViewPath,57-iFileLen-10) & "..." & Right(sViewPath,iFileLen + 10) + Else + sViewPath = Left(sViewPath,27) & " ... " & Right(sViewPath,28) + End If + End If + CutPathView = sViewPath +End Function + + +' Deletes the content of all cells that are softformatted according +' to the 'InputStyleName' +Sub DeleteInputCells(oSheet as Object, InputStyleName as String) +Dim oRanges as Object +Dim oRange as Object + oRanges = oSheet.CellFormatRanges.createEnumeration + While oRanges.hasMoreElements + oRange = oRanges.NextElement + If Instr(1,oRange.CellStyle, InputStyleName) <> 0 Then + Call ReplaceRangeValues(oRange, "") + End If + Wend +End Sub + + +' Inserts a certain string to all cells of a range that is passed +' either as an object or as the RangeName +Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String) +Dim oCellRange as Object + If Vartype(Range) = 8 Then + ' Get the Range out of the Rangename + oCellRange = oSheet.GetCellRangeByName(Range) + Else + ' The range is passed as an object + Set oCellRange = Range + End If + If IsMissing(StyleName) Then + ReplaceRangeValues(oCellRange, ReplaceValue) + Else + If Instr(1,oCellRange.CellStyle,StyleName) Then + ReplaceRangeValues(oCellRange, ReplaceValue) + End If + End If +End Sub + + +Sub ReplaceRangeValues(oRange as Object, ReplaceValue) +Dim oRangeAddress as Object +Dim ColCount as Integer +Dim RowCount as Integer +Dim i as Integer + oRangeAddress = oRange.RangeAddress + ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn + RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow + Dim FillArray(RowCount) as Variant + Dim sLine(ColCount) as Variant + For i = 0 To ColCount + sLine(i) = ReplaceValue + Next i + For i = 0 To RowCount + FillArray(i) = sLine() + Next i + oRange.DataArray = FillArray() +End Sub + + +' Returns the Value of the first cell of a Range +Function GetValueofCellbyName(oSheet as Object, sCellName as String) +Dim oCell as Object + oCell = GetCellByName(oSheet, sCellName) + GetValueofCellbyName = oCell.Value +End Function + + +Function DuplicateRow(oSheet as Object, RangeName as String) +Dim oRange as Object +Dim oCell as Object +Dim oCellAddress as New com.sun.star.table.CellAddress +Dim oRangeAddress as New com.sun.star.table.CellRangeAddress + oRange = oSheet.GetCellRangeByName(RangeName) + oRangeAddress = oRange.RangeAddress + oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow) + oCellAddress = oCell.CellAddress + oSheet.Rows.InsertByIndex(oCellAddress.Row,1) + oRangeAddress = oRange.RangeAddress + oSheet.CopyRange(oCellAddress, oRangeAddress) + DuplicateRow = oRangeAddress.StartRow-1 +End Function + + +' Returns the String of the first cell of a Range +Function GetStringofCellbyName(oSheet as Object, sCellName as String) +Dim oCell as Object + oCell = GetCellByName(oSheet, sCellName) + GetStringofCellbyName = oCell.String +End Function + + +' Returns a named Cell +Function GetCellByName(oSheet as Object, sCellName as String) as Object +Dim oCellRange as Object +Dim oCellAddress as Object + oCellRange = oSheet.GetCellRangeByName(sCellName) + oCellAddress = oCellRange.RangeAddress + GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow) +End Function + + +' Changes the numeric Value of a cell by transmitting the String of the numeric Value +Sub ChangeCellValue(oCell as Object, ValueString as String) +Dim CellValue + oCell.Formula = "=Value(" & """" & ValueString & """" & ")" + CellValue = oCell.Value + oCell.Formula = "" + oCell.Value = CellValue +End Sub + + +Function GetDocumentType(oDocument) + On Local Error GoTo NODOCUMENTTYPE +' ShowSupportedServiceNames(oDocument) + If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then + GetDocumentType() = "scalc" + ElseIf oDocument.SupportsService("com.sun.star.text.TextDocument") Then + GetDocumentType() = "swriter" + ElseIf oDocument.SupportsService("com.sun.star.drawing.DrawingDocument") Then + GetDocumentType() = "sdraw" + ElseIf oDocument.SupportsService("com.sun.star.presentation.PresentationDocument") Then + GetDocumentType() = "simpress" + ElseIf oDocument.SupportsService("com.sun.star.formula.FormulaProperties") Then + GetDocumentType() = "smath" + End If + NODOCUMENTTYPE: + If Err <> 0 Then + GetDocumentType = "" + Resume GOON + GOON: + End If +End Function + + +Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer +Dim ThisFormatKey as Long +Dim oObjectFormat as Object + On Local Error Goto NOFORMAT + ThisFormatKey = oFormatObject.NumberFormat + oObjectFormat = oDocFormats.GetByKey(ThisFormatKey) + GetNumberFormatType = oObjectFormat.Type + NOFORMAT: + If Err <> 0 Then + Msgbox("Numberformat of Object is not available!", 16, GetProductName()) + GetNumberFormatType = 0 + GOTO NOERROR + End If + NOERROR: + On Local Error Goto 0 +End Function + + +Sub ProtectSheets(Optional oSheets as Object) +Dim i as Integer +Dim oDocSheets as Object + If IsMissing(oSheets) Then + oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets + Else + Set oDocSheets = oSheets + End If + + For i = 0 To oDocSheets.Count-1 + oDocSheets(i).Protect("") + Next i +End Sub + + +Sub UnprotectSheets(Optional oSheets as Object) +Dim i as Integer +Dim oDocSheets as Object + If IsMissing(oSheets) Then + oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets + Else + Set oDocSheets = oSheets + End If + + For i = 0 To oDocSheets.Count-1 + oDocSheets(i).Unprotect("") + Next i +End Sub + + +Function GetRowIndex(oSheet as Object, RowName as String) +Dim oRange as Object + oRange = oSheet.GetCellRangeByName(RowName) + GetRowIndex = oRange.RangeAddress.StartRow +End Function + + +Function GetColumnIndex(oSheet as Object, ColName as String) +Dim oRange as Object + oRange = oSheet.GetCellRangeByName(ColName) + GetColumnIndex = oRange.RangeAddress.StartColumn +End Function + + +Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object +Dim oSheet as Object +Dim Count as Integer +Dim BasicSheetName as String + + BasicSheetName = NewName + ' Copy the last table. Assumption: The last table is the template + On Local Error Goto RENAMESHEET + oSheets.CopybyName(OldName, NewName, DestPos) + +RENAMESHEET: + oSheet = oSheets(DestPos) + If Err <> 0 Then + ' Test if renaming failed + Count = 2 + Do While oSheet.Name <> NewName + NewName = BasicSheetName & "_" & Count + oSheet.Name = NewName + Count = Count + 1 + Loop + Resume CL_ERROR +CL_ERROR: + End If + CopySheetbyName = oSheet +End Function + + +' Dis-or enables a Window and adjusts the mousepointer accordingly +Sub ToggleWindow(bDoEnable as Boolean) +Dim oWindow as Object + oWindow = StarDesktop.CurrentFrame.ComponentWindow + oWindow.Enable = bDoEnable +End Sub + + +Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String +Dim nStartFlags as Long +Dim nContFlags as Long +Dim oCharService as Object +Dim iSheetNameLength as Integer +Dim iResultPos as Integer +Dim WrongChar as String +Dim oResult as Object + nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE + nContFlags = nStartFlags + oCharService = CreateUnoService("com.sun.star.i18n.CharacterClassification") + iSheetNameLength = Len(SheetName) + If IsMissing(oLocale) Then + oLocale = ThisComponent.CharLocale + End If + Do + oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, "", nContFlags, " ") + iResultPos = oResult.EndPos + If iResultPos < iSheetNameLength Then + WrongChar = Mid(SheetName, iResultPos+1,1) + SheetName = ReplaceString(SheetName,"_", WrongChar) + End If + Loop Until iResultPos = iSheetNameLength + CheckNewSheetname = SheetName +End Function + + +Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String) +Dim Count as Integer +Dim bSheetIsThere as Boolean +Dim iSheetNameLength as Integer + iSheetNameLength = Len(SheetName) + Count = 2 + Do + bSheetIsThere = oSheets.HasByName(SheetName) + If bSheetIsThere Then + SheetName = Right(SheetName,iSheetNameLength) & "_" & Count + Count = Count + 1 + End If + Loop Until Not bSheetIsThere + AddNewSheetname = SheetName +End Sub + + +Function GetSheetIndex(oSheets, sName) as Integer +Dim i as Integer + For i = 0 To oSheets.Count-1 + If oSheets(i).Name = sName Then + GetSheetIndex = i + exit Function + End If + Next i + GetSheetIndex = -1 +End Function + + +Function GetLastUsedRow(oSheet as Object) as Long +Dim oCell As Object +Dim oCursor As Object +Dim aAddress As Variant + oCell = oSheet.GetCellbyPosition(0, 0) + oCursor = oSheet.createCursorByRange(oCell) + oCursor.GotoEndOfUsedArea(True) + aAddress = oCursor.RangeAddress + GetLastUsedRow = aAddress.EndRow +End Function + + +' Note To set a one lined frame you have to set the inner width to 0 +' In the API all Units that refer to pt-Heights are "1/100mm" +' The convert factor from 1pt to 1/100 mm is approximately 35 +Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer) +Dim aBorder as New com.sun.star.table.BorderLine + aBorder = oStyleBorder + aBorder.InnerLineWidth = iInnerLineWidth + aBorder.OuterLineWidth = iOuterLineWidth + ModifyBorderLineWidth = aBorder +End Function + + +Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String) +Dim PropValue(1) as new com.sun.star.beans.PropertyValue + PropValue(0).Name = "EventType" + PropValue(0).Value = "StarBasic" + PropValue(1).Name = "Script" + PropValue(1).Value = "macro:///" & SubPath + oDocument.Events.ReplaceByName(EventName, PropValue()) +End Sub + + + +Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue) +Dim MaxIndex as Integer +Dim i as Integer +Dim a as Integer + MaxIndex = Ubound(oContent()) + bDoReplace = False + For i = 0 To MaxIndex + a = GetPropertyValueIndex(oContent(i).Name, TargetProperties()) + If a <> -1 Then + If Vartype(TargetProperties(a).Value) <> 9 Then + If TargetProperties(a).Value <> oContent(i).Value Then + oContent(i).Value = TargetProperties(a).Value + bDoReplace = True + End If + Else + If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then + oContent(i).Value = TargetProperties(a).Value + bDoReplace = True + End If + End If + End If + Next i + ModifyPropertyValue() = bDoReplace +End Function + + +Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer +Dim i as Integer + For i = 0 To Ubound(TargetProperties()) + If Searchname = TargetProperties(i).Name Then + GetPropertyValueIndex = i + Exit Function + End If + Next i + GetPropertyValueIndex() = -1 +End Function + + +Sub DispatchSlot(SlotID as Integer) +Dim oArg() as new com.sun.star.beans.PropertyValue +Dim oUrl as new com.sun.star.util.URL +Dim oTrans as Object +Dim oDisp as Object + oTrans = createUNOService("com.sun.star.util.URLTransformer") + oUrl.Complete = "slot:" & CStr(SlotID) + oTrans.parsestrict(oUrl) + oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, "_self", 0) + oDisp.dispatch(oUrl, oArg()) +End Sub + + +'returns the type of the office application +'FatOffice = 0, WebTop = 1 +'This routine has to be changed if the Product Name is being changed! +Function IsFatOffice() As Boolean + If sProductname = "" Then + sProductname = GetProductname() + End If + IsFatOffice = TRUE + 'The following line has to include the current productname + If Instr(1,sProductname,"WebTop",1) <> 0 Then + IsFatOffice = FALSE + End If +End Function + + +Sub ToggleDesignMode(oDocument as Object) +Dim aSwitchMode as new com.sun.star.util.URL + aSwitchMode.Complete = ".uno:SwitchControlDesignMode" + aTransformer = createUnoService("com.sun.star.util.URLTransformer") + aTransformer.parseStrict(aSwitchMode) + oFrame = oDocument.currentController.Frame + oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63) + Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue + oDispatch.dispatch(aSwitchMode, aEmptyArgs()) + Erase aSwitchMode +End Sub + + +Function isHighContrast(oPeer as Object) + Dim UIColor as Long + Dim myRed as Integer + Dim myGreen as Integer + Dim myBlue as Integer + Dim myLuminance as Double + + UIColor = oPeer.getProperty( "DisplayBackgroundColor" ) + myRed = Red (UIColor) + myGreen = Green (UIColor) + myBlue = Blue (UIColor) + myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256 ) + isHighContrast = false + If myLuminance <= 25 Then isHighContrast = true +End Function + + +Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object +Dim NoArgs() as new com.sun.star.beans.PropertyValue +Dim oDocument as Object +Dim sUrl as String +Dim ErrMsg as String + On Local Error Goto NOMODULEINSTALLED + sUrl = "private:factory/" & sType + oDocument = StarDesktop.LoadComponentFromURL(sUrl,"_default",0, NoArgs()) +NOMODULEINSTALLED: + If (Err <> 0) OR IsNull(oDocument) Then + If InitResources("") Then + Select Case sType + Case "swriter" + ErrMsg = GetResText("RID_COMMON_1") + Case "scalc" + ErrMsg = GetResText("RID_COMMON_2") + Case "simpress" + ErrMsg = GetResText("RID_COMMON_3") + Case "sdraw" + ErrMsg = GetResText("RID_COMMON_4") + Case "smath" + ErrMsg = GetResText("RID_COMMON_5") + Case Else + ErrMsg = "Invalid Document Type!" + End Select + ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>") + If Not IsMissing(sAddMsg) Then + ErrMsg = ErrMsg & chr(13) & sAddMsg + End If + Msgbox(ErrMsg, 48, GetProductName()) + End If + If Err <> 0 Then + Resume GOON + End If + End If +GOON: + CreateNewDocument = oDocument +End Function + + +' This Sub has been used in order to ensure that after disposing a document +' from the backing window it is returned to the backing window, so the +' office won't be closed +Sub DisposeDocument(oDocument as Object) +Dim dispatcher as Object +Dim parser as Object +Dim disp as Object +Dim url as new com.sun.star.util.URL +Dim NoArgs() as New com.sun.star.beans.PropertyValue +Dim oFrame as Object + If Not IsNull(oDocument) Then + oDocument.setModified(false) + parser = createUnoService("com.sun.star.util.URLTransformer") + url.Complete = ".uno:CloseDoc" + parser.parseStrict(url) + oFrame = oDocument.CurrentController.Frame + disp = oFrame.queryDispatch(url,"_self", com.sun.star.util.SearchFlags.NORM_WORD_ONLY) + disp.dispatch(url, NoArgs()) + End If +End Sub + +'Function to calculate if the year is a leap year +Function CalIsLeapYear(ByVal iYear as Integer) as Boolean + CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 <> 0) Or (iYear Mod 400 = 0))) +End Function + diff --git a/wizards/source/tools/ModuleControls.xba b/wizards/source/tools/ModuleControls.xba new file mode 100644 index 000000000..059956cb1 --- /dev/null +++ b/wizards/source/tools/ModuleControls.xba @@ -0,0 +1,387 @@ + + + +Option Explicit + +Public DlgOverwrite as Object +Public Const SBOVERWRITEUNDEFINED as Integer = 0 +Public Const SBOVERWRITECANCEL as Integer = 2 +Public Const SBOVERWRITEQUERY as Integer = 7 +Public Const SBOVERWRITEALWAYS as Integer = 6 +Public Const SBOVERWRITENEVER as Integer = 8 +Public iGeneralOverwrite as Integer + + + +' Accepts the name of a control and returns the respective control model as object +' The Container can either be a whole document or a specific sheet of a Calc-Document +' 'CName' is the name of the Control +Function getControlModel(oContainer as Object, CName as String) +Dim aForm, oForms as Object +Dim i as Integer + oForms = oContainer.Drawpage.GetForms + For i = 0 To oForms.Count-1 + aForm = oForms.GetbyIndex(i) + If aForm.HasByName(CName) Then + GetControlModel = aForm.GetbyName(CName) + Exit Function + End If + Next i + Msgbox("No Control with the name '" & CName & "' found" , 16, GetProductName()) +End Function + + + +' Gets the Shape of a Control( e. g. to reset the size or Position of the control +' Parameters: +' The 'oContainer' is the Document or a specific sheet of a Calc - Document +' 'CName' is the Name of the Control +Function GetControlShape(oContainer as Object,CName as String) +Dim i as integer +Dim aShape as Object + For i = 0 to oContainer.DrawPage.Count-1 + aShape = oContainer.DrawPage(i) + If HasUnoInterfaces(aShape, "com.sun.star.drawing.XControlShape") then + If ashape.Control.Name = CName then + GetControlShape = aShape + exit Function + End If + End If + Next +End Function + + +' Returns the View of a Control +' Parameters: +' The 'oContainer' is the Document or a specific sheet of a Calc - Document +' The 'oController' is always directly attached to the Document +' 'CName' is the Name of the Control +Function getControlView(oContainer , oController as Object, CName as String) as Object +Dim aForm, oForms, oControlModel as Object +Dim i as Integer + oForms = oContainer.DrawPage.Forms + For i = 0 To oForms.Count-1 + aForm = oforms.GetbyIndex(i) + If aForm.HasByName(CName) Then + oControlModel = aForm.GetbyName(CName) + GetControlView = oController.GetControl(oControlModel) + Exit Function + End If + Next i + Msgbox("No Control with the name '" & CName & "' found" , 16, GetProductName()) +End Function + + + +' Parameters: +' The 'oContainer' is the Document or a specific sheet of a Calc - Document +' 'CName' is the Name of the Control +Function DisposeControl(oContainer as Object, CName as String) as Boolean +Dim aControl as Object + + aControl = GetControlModel(oContainer,CName) + If not IsNull(aControl) Then + aControl.Dispose() + DisposeControl = True + Else + DisposeControl = False + End If +End Function + + +' Returns a sequence of a group of controls like option buttons or checkboxes +' The 'oContainer' is the Document or a specific sheet of a Calc - Document +' 'sGroupName' is the Name of the Controlgroup +Function GetControlGroupModel(oContainer as Object, sGroupName as String ) +Dim aForm, oForms As Object +Dim aControlModel() As Object +Dim i as integer + + oForms = oContainer.DrawPage.Forms + For i = 0 To oForms.Count-1 + aForm = oForms(i) + If aForm.HasbyName(sGroupName) Then + aForm.GetGroupbyName(sGroupName,aControlModel) + GetControlGroupModel = aControlModel + Exit Function + End If + Next i + Msgbox("No Controlgroup with the name '" & sGroupName & "' found" , 16, GetProductName()) +End Function + + +' Returns the Referencevalue of a group of e.g. option buttons or check boxes +' 'oControlGroup' is a sequence of the Control objects +Function GetRefValue(oControlGroup() as Object) +Dim i as Integer + For i = 0 To Ubound(oControlGroup()) +' oControlGroup(i).DefaultState = oControlGroup(i).State + If oControlGroup(i).State Then + GetRefValue = oControlGroup(i).RefValue + exit Function + End If + Next + GetRefValue() = -1 +End Function + + +Function GetRefValueOfControlGroup(oContainer as Object, GroupName as String) +Dim oOptGroup() as Object +Dim iRef as Integer + oOptGroup() = GetControlGroupModel(oContainer, GroupName) + iRef = GetRefValue(oOptGroup()) + GetRefValueofControlGroup = iRef +End Function + + +Function GetOptionGroupValue(oContainer as Object, OptGroupName as String) as Boolean +Dim oRulesOptions() as Object + oRulesOptions() = GetControlGroupModel(oContainer, OptGroupName) + GetOptionGroupValue = oRulesOptions(0).State +End Function + + + +Function WriteOptValueToCell(oSheet as Object, OptGroupName as String, iCol as Integer, iRow as Integer) as Boolean +Dim bOptValue as Boolean +Dim oCell as Object + bOptValue = GetOptionGroupValue(oSheet, OptGroupName) + oCell = oSheet.GetCellByPosition(iCol, iRow) + oCell.SetValue(ABS(CInt(bOptValue))) + WriteOptValueToCell() = bOptValue +End Function + + +Function LoadDialog(Libname as String, DialogName as String, Optional oLibContainer) +Dim oLib as Object +Dim oLibDialog as Object +Dim oRuntimeDialog as Object + If IsMissing(oLibContainer ) then + oLibContainer = DialogLibraries + End If + oLibContainer.LoadLibrary(LibName) + oLib = oLibContainer.GetByName(Libname) + oLibDialog = oLib.GetByName(DialogName) + oRuntimeDialog = CreateUnoDialog(oLibDialog) + LoadDialog() = oRuntimeDialog +End Function + + +Sub GetFolderName(oRefModel as Object) +Dim oFolderDialog as Object +Dim iAccept as Integer +Dim sPath as String +Dim InitPath as String +Dim RefControlName as String +Dim oUcb as object + 'Note: The following services have to be called in the following order + ' because otherwise Basic does not remove the FileDialog Service + oFolderDialog = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker") + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + InitPath = ConvertToUrl(oRefModel.Text) + If InitPath = "" Then + InitPath = GetPathSettings("Work") + End If + If oUcb.Exists(InitPath) Then + oFolderDialog.SetDisplayDirectory(InitPath) + End If + iAccept = oFolderDialog.Execute() + If iAccept = 1 Then + sPath = oFolderDialog.GetDirectory() + If oUcb.Exists(sPath) Then + oRefModel.Text = ConvertFromUrl(sPath) + End If + End If +End Sub + + +Sub GetFileName(oRefModel as Object, Filternames()) +Dim oFileDialog as Object +Dim iAccept as Integer +Dim sPath as String +Dim InitPath as String +Dim RefControlName as String +Dim oUcb as object +'Dim ListAny(0) + 'Note: The following services have to be called in the following order + ' because otherwise Basic does not remove the FileDialog Service + oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + 'ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE + 'oFileDialog.initialize(ListAny()) + AddFiltersToDialog(FilterNames(), oFileDialog) + InitPath = ConvertToUrl(oRefModel.Text) + If InitPath = "" Then + InitPath = GetPathSettings("Work") + End If + If oUcb.Exists(InitPath) Then + oFileDialog.SetDisplayDirectory(InitPath) + End If + iAccept = oFileDialog.Execute() + If iAccept = 1 Then + sPath = oFileDialog.Files(0) + If oUcb.Exists(sPath) Then + oRefModel.Text = ConvertFromUrl(sPath) + End If + End If + oFileDialog.Dispose() +End Sub + + +Function StoreDocument(oDocument as Object, FilterNames() as String, DefaultName as String, DisplayDirectory as String, Optional iAddProcedure as Integer) as String +Dim NoArgs() as New com.sun.star.beans.PropertyValue +Dim oStoreProperties(0) as New com.sun.star.beans.PropertyValue +Dim oStoreDialog as Object +Dim iAccept as Integer +Dim sPath as String +Dim ListAny(0) as Long +Dim UIFilterName as String +Dim FilterName as String +Dim FilterIndex as Integer + ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION_PASSWORD + oStoreDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker") + oStoreDialog.Initialize(ListAny()) + AddFiltersToDialog(FilterNames(), oStoreDialog) + oStoreDialog.SetDisplayDirectory(DisplayDirectory) + oStoreDialog.SetDefaultName(DefaultName) + oStoreDialog.setValue(com.sun.star.ui.dialogs.ExtendedFilePickerElementIds.CHECKBOX_AUTOEXTENSION,0, true) + + iAccept = oStoreDialog.Execute() + If iAccept = 1 Then + sPath = oStoreDialog.Files(0) + UIFilterName = oStoreDialog.GetCurrentFilter() + FilterIndex = IndexInArray(UIFilterName, FilterNames()) + FilterName = FilterNames(FilterIndex,2) + If Not IsMissing(iAddProcedure) Then + Select Case iAddProcedure + Case 1 + CommitLastDocumentChanges(sPath) + End Select + End If + On Local Error Goto NOSAVING + If FilterName = "" Then + ' Todo: Catch the case that a document that has to be overwritten is writeprotected (e.g. it is open) + oDocument.StoreAsUrl(sPath, NoArgs()) + Else + oStoreProperties(0).Name = "FilterName" + oStoreProperties(0).Value = FilterName + oDocument.StoreAsUrl(sPath, oStoreProperties()) + End If + End If + oStoreDialog.dispose() + StoreDocument() = sPath + Exit Function +NOSAVING: + If Err <> 0 Then +' Msgbox("Document cannot be saved under '" & ConvertFromUrl(sPath) & "'", 48, GetProductName()) + sPath = "" + oStoreDialog.dispose() + Resume NOERROR + NOERROR: + End If +End Function + + +Sub AddFiltersToDialog(FilterNames() as String, oDialog as Object) +Dim i as Integer +Dim MaxIndex as Integer +Dim ViewFiltername as String +Dim oProdNameAccess as Object +Dim sProdName as String + oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product") + sProdName = oProdNameAccess.getByName("ooName") + MaxIndex = Ubound(FilterNames(), 1) + For i = 0 To MaxIndex + Filternames(i,0) = ReplaceString(Filternames(i,0), sProdName,"%productname%") + oDialog.AppendFilter(FilterNames(i,0), FilterNames(i,1)) + Next i + oDialog.SetCurrentFilter(FilterNames(0,0)) +End Sub + + +Sub SwitchMousePointer(oWindowPeer as Object, bDoEnable as Boolean) +Dim oWindowPointer as Object + oWindowPointer = CreateUnoService("com.sun.star.awt.Pointer") + If bDoEnable Then + oWindowPointer.SetType(com.sun.star.awt.SystemPointer.ARROW) + Else + oWindowPointer.SetType(com.sun.star.awt.SystemPointer.WAIT) + End If + oWindowPeer.SetPointer(oWindowPointer) +End Sub + + +Sub ShowOverwriteAllDialog(FilePath as String, sTitle as String) +Dim QueryString as String +Dim LocRetValue as Integer +Dim lblYes as String +Dim lblNo as String +Dim lblYesToAll as String +Dim lblCancel as String +Dim OverwriteModel as Object + If InitResources(GetProductName()) Then + QueryString = GetResText("RID_COMMON_7") + QueryString = ReplaceString(QueryString, ConvertFromUrl(FilePath), "<PATH>") + If Len(QueryString) > 190 Then + QueryString = DeleteStr(QueryString, ".<BR>") + End If + QueryString = ReplaceString(QueryString, chr(13), "<BR>") + lblYes = GetResText("RID_COMMON_8") + lblYesToAll = GetResText("RID_COMMON_9") + lblNo = GetResText("RID_COMMON_10") + lblCancel = GetResText("RID_COMMON_11") + DlgOverwrite = LoadDialog("Tools", "DlgOverwriteAll") + DlgOverwrite.Title = sTitle + OverwriteModel = DlgOverwrite.Model + OverwriteModel.cmdYes.Label = lblYes + OverwriteModel.cmdYesToAll.Label = lblYesToAll + OverwriteModel.cmdNo.Label = lblNo + OverwriteModel.cmdCancel.Label = lblCancel + OverwriteModel.lblQueryforSave.Label = QueryString + OverwriteModel.cmdNo.DefaultButton = True + DlgOverwrite.GetControl("cmdNo").SetFocus() + iGeneralOverwrite = 999 + LocRetValue = DlgOverwrite.execute() + If iGeneralOverwrite = 999 Then + iGeneralOverwrite = SBOVERWRITECANCEL + End If + DlgOverwrite.dispose() + Else + iGeneralOverwrite = SBOVERWRITECANCEL + End If +End Sub + + +Sub SetOVERWRITEToQuery() + iGeneralOverwrite = SBOVERWRITEQUERY + DlgOverwrite.EndExecute() +End Sub + + +Sub SetOVERWRITEToAlways() + iGeneralOverwrite = SBOVERWRITEALWAYS + DlgOverwrite.EndExecute() +End Sub + + +Sub SetOVERWRITEToNever() + iGeneralOverwrite = SBOVERWRITENEVER + DlgOverwrite.EndExecute() +End Sub + diff --git a/wizards/source/tools/Strings.xba b/wizards/source/tools/Strings.xba new file mode 100644 index 000000000..bb1593a20 --- /dev/null +++ b/wizards/source/tools/Strings.xba @@ -0,0 +1,469 @@ + + + +Option Explicit +Public sProductname as String + + +' Deletes out of a String 'BigString' all possible PartStrings, that are summed up +' in the Array 'ElimArray' +Function ElimChar(ByVal BigString as String, ElimArray() as String) +Dim i% ,n% + For i = 0 to Ubound(ElimArray) + BigString = DeleteStr(BigString,ElimArray(i)) + Next + ElimChar = BigString +End Function + + +' Deletes out of a String 'BigString' a possible Partstring 'CompString' +Function DeleteStr(ByVal BigString,CompString as String) as String +Dim i%, CompLen%, BigLen% + CompLen = Len(CompString) + i = 1 + While i <> 0 + i = Instr(i, BigString,CompString) + If i <> 0 then + BigLen = Len(BigString) + BigString = Mid(BigString,1,i-1) + Mid(BigString,i+CompLen,BigLen-i+1-CompLen) + End If + Wend + DeleteStr = BigString +End Function + + +' Finds a PartString, that is framed by the Strings 'Prestring' and 'PostString' +Function FindPartString(BigString, PreString, PostString as String, SearchPos as Integer) as String +Dim StartPos%, EndPos% +Dim BigLen%, PreLen%, PostLen% + StartPos = Instr(SearchPos,BigString,PreString) + If StartPos <> 0 Then + PreLen = Len(PreString) + EndPos = Instr(StartPos + PreLen,BigString,PostString) + If EndPos <> 0 Then + BigLen = Len(BigString) + PostLen = Len(PostString) + FindPartString = Mid(BigString,StartPos + PreLen, EndPos - (StartPos + PreLen)) + SearchPos = EndPos + PostLen + Else + Msgbox("No final tag for '" & PreString & "' existing", 16, GetProductName()) + FindPartString = "" + End If + Else + FindPartString = "" + End If +End Function + + +' Note iCompare = 0 (Binary comparison) +' iCompare = 1 (Text comparison) +Function PartStringInArray(BigArray(), SearchString as String, iCompare as Integer) as Integer +Dim MaxIndex as Integer +Dim i as Integer + MaxIndex = Ubound(BigArray()) + For i = 0 To MaxIndex + If Instr(1, BigArray(i), SearchString, iCompare) <> 0 Then + PartStringInArray() = i + Exit Function + End If + Next i + PartStringInArray() = -1 +End Function + + +' Deletes the String 'SmallString' out of the String 'BigString' +' in case SmallString's Position in BigString is right at the end +Function RTrimStr(ByVal BigString, SmallString as String) as String +Dim SmallLen as Integer +Dim BigLen as Integer + SmallLen = Len(SmallString) + BigLen = Len(BigString) + If Instr(1,BigString, SmallString) <> 0 Then + If Mid(BigString,BigLen + 1 - SmallLen, SmallLen) = SmallString Then + RTrimStr = Mid(BigString,1,BigLen - SmallLen) + Else + RTrimStr = BigString + End If + Else + RTrimStr = BigString + End If +End Function + + +' Deletes the Char 'CompChar' out of the String 'BigString' +' in case CompChar's Position in BigString is right at the beginning +Function LTRimChar(ByVal BigString as String,CompChar as String) as String +Dim BigLen as integer + BigLen = Len(BigString) + If BigLen > 1 Then + If Left(BigString,1) = CompChar then + BigString = Mid(BigString,2,BigLen-1) + End If + ElseIf BigLen = 1 Then + BigString = "" + End If + LTrimChar = BigString +End Function + + +' Retrieves an Array out of a String. +' The fields of the Array are separated by the parameter 'Separator', that is contained +' in the Array +' The Array MaxIndex delivers the highest Index of this Array +Function ArrayOutOfString(BigString, Separator as String, Optional MaxIndex as Integer) +Dim LocList() as String + LocList=Split(BigString,Separator) + + If not isMissing(MaxIndex) then maxIndex=ubound(LocList()) + + ArrayOutOfString=LocList +End Function + + +' Deletes all fieldvalues in one-dimensional Array +Sub ClearArray(BigArray) +Dim i as integer + For i = Lbound(BigArray()) to Ubound(BigArray()) + BigArray(i) = "" + Next +End Sub + + +' Deletes all fieldvalues in a multidimensional Array +Sub ClearMultiDimArray(BigArray,DimCount as integer) +Dim n%, m% + For n = Lbound(BigArray(),1) to Ubound(BigArray(),1) + For m = 0 to Dimcount - 1 + BigArray(n,m) = "" + Next m + Next n +End Sub + + +' Checks if a Field (LocField) is already defined in an Array +' Returns 'True' or 'False' +Function FieldInArray(LocArray(), MaxIndex as integer, LocField as String) As Boolean +Dim i as integer + For i = Lbound(LocArray()) to MaxIndex + If UCase(LocArray(i)) = UCase(LocField) Then + FieldInArray = True + Exit Function + End if + Next + FieldInArray = False +End Function + + +' Checks if a Field (LocField) is already defined in an Array +' Returns 'True' or 'False' +Function FieldInList(LocField, BigList()) As Boolean +Dim i as integer + For i = Lbound(BigList()) to Ubound(BigList()) + If LocField = BigList(i) Then + FieldInList = True + Exit Function + End if + Next + FieldInList = False +End Function + + +' Retrieves the Index of the delivered String 'SearchString' in +' the Array LocList()' +Function IndexInArray(SearchString as String, LocList()) as Integer +Dim i as integer + For i = Lbound(LocList(),1) to Ubound(LocList(),1) + If UCase(LocList(i,0)) = UCase(SearchString) Then + IndexInArray = i + Exit Function + End if + Next + IndexInArray = -1 +End Function + + +Sub MultiArrayInListbox(oDialog as Object, ListboxName as String, ValList(), iDim as Integer) +Dim oListbox as Object +Dim i as integer +Dim a as Integer + a = 0 + oListbox = oDialog.GetControl(ListboxName) + oListbox.RemoveItems(0, oListbox.GetItemCount) + For i = 0 to Ubound(ValList(), 1) + If ValList(i) <> "" Then + oListbox.AddItem(ValList(i, iDim-1), a) + a = a + 1 + End If + Next +End Sub + + +' Searches for a String in a two-dimensional Array by querying all Searchindexes of the second dimension +' and delivers the specific String of the ReturnIndex in the second dimension of the Searchlist() +Function StringInMultiArray(SearchList(), SearchString as String, SearchIndex as Integer, ReturnIndex as Integer, Optional MaxIndex as Integer) as String +Dim i as integer +Dim CurFieldString as String + If IsMissing(MaxIndex) Then + MaxIndex = Ubound(SearchList(),1) + End If + For i = Lbound(SearchList()) to MaxIndex + CurFieldString = SearchList(i,SearchIndex) + If UCase(CurFieldString) = UCase(SearchString) Then + StringInMultiArray() = SearchList(i,ReturnIndex) + Exit Function + End if + Next + StringInMultiArray() = "" +End Function + + +' Searches for a Value in multidimensial Array by querying all Searchindices of the passed dimension +' and delivers the Index where it is found. +Function GetIndexInMultiArray(SearchList(), SearchValue, SearchIndex as Integer) as Integer +Dim i as integer +Dim MaxIndex as Integer +Dim CurFieldValue + MaxIndex = Ubound(SearchList(),1) + For i = Lbound(SearchList()) to MaxIndex + CurFieldValue = SearchList(i,SearchIndex) + If CurFieldValue = SearchValue Then + GetIndexInMultiArray() = i + Exit Function + End if + Next + GetIndexInMultiArray() = -1 +End Function + + +' Searches for a Value in multidimensial Array by querying all Searchindices of the passed dimension +' and delivers the Index where the Searchvalue is found as a part string +Function GetIndexForPartStringinMultiArray(SearchList(), SearchValue, SearchIndex as Integer) as Integer +Dim i as integer +Dim MaxIndex as Integer +Dim CurFieldValue + MaxIndex = Ubound(SearchList(),1) + For i = Lbound(SearchList()) to MaxIndex + CurFieldValue = SearchList(i,SearchIndex) + If Instr(CurFieldValue, SearchValue) > 0 Then + GetIndexForPartStringinMultiArray() = i + Exit Function + End if + Next + GetIndexForPartStringinMultiArray = -1 +End Function + + +Function ArrayfromMultiArray(MultiArray as String, iDim as Integer) +Dim MaxIndex as Integer +Dim i as Integer + MaxIndex = Ubound(MultiArray()) + Dim ResultArray(MaxIndex) as String + For i = 0 To MaxIndex + ResultArray(i) = MultiArray(i,iDim) + Next i + ArrayfromMultiArray() = ResultArray() +End Function + + +' Replaces the string "OldReplace" through the String "NewReplace" in the String +' 'BigString' +Function ReplaceString(ByVal Bigstring, NewReplace, OldReplace as String) as String + ReplaceString=join(split(BigString,OldReplace),NewReplace) +End Function + + +' Retrieves the second value for a next to 'SearchString' in +' a two-dimensional string-Array +Function FindSecondValue(SearchString as String, TwoDimList() as String ) as String +Dim i as Integer + For i = 0 To Ubound(TwoDimList,1) + If UCase(SearchString) = UCase(TwoDimList(i,0)) Then + FindSecondValue = TwoDimList(i,1) + Exit For + End If + Next +End Function + + +' raises a base to a certain power +Function Power(Basis as Double, Exponent as Double) as Double + Power = Exp(Exponent*Log(Basis)) +End Function + + +' rounds a Real to a given Number of Decimals +Function Round(BaseValue as Double, Decimals as Integer) as Double +Dim Multiplicator as Long +Dim DblValue#, RoundValue# + Multiplicator = Power(10,Decimals) + RoundValue = Int(BaseValue * Multiplicator) + Round = RoundValue/Multiplicator +End Function + + +'Retrieves the mere filename out of a whole path +Function FileNameoutofPath(ByVal Path as String, Optional Separator as String) as String +Dim i as Integer +Dim SepList() as String + If IsMissing(Separator) Then + Path = ConvertFromUrl(Path) + Separator = GetPathSeparator() + End If + SepList() = ArrayoutofString(Path, Separator,i) + FileNameoutofPath = SepList(i) +End Function + + +Function GetFileNameExtension(ByVal FileName as String) +Dim MaxIndex as Integer +Dim SepList() as String + SepList() = ArrayoutofString(FileName,".", MaxIndex) + GetFileNameExtension = SepList(MaxIndex) +End Function + + +Function GetFileNameWithoutExtension(ByVal FileName as String, Optional Separator as String) +Dim MaxIndex as Integer +Dim SepList() as String + If not IsMissing(Separator) Then + FileName = FileNameoutofPath(FileName, Separator) + End If + SepList() = ArrayoutofString(FileName,".", MaxIndex) + GetFileNameWithoutExtension = RTrimStr(FileName, "." & SepList(MaxIndex)) +End Function + + +Function DirectoryNameoutofPath(sPath as String, Separator as String) as String +Dim LocFileName as String + LocFileName = FileNameoutofPath(sPath, Separator) + DirectoryNameoutofPath = RTrimStr(sPath, Separator & LocFileName) +End Function + + +Function CountCharsInString(BigString, LocChar as String, ByVal StartPos as Integer) as Integer +Dim LocCount%, LocPos% + LocCount = 0 + Do + LocPos = Instr(StartPos,BigString,LocChar) + If LocPos <> 0 Then + LocCount = LocCount + 1 + StartPos = LocPos+1 + End If + Loop until LocPos = 0 + CountCharsInString = LocCount +End Function + + +Function BubbleSortList(ByVal SortList(),optional sort2ndValue as Boolean) +'This function bubble sorts an array of maximum 2 dimensions. +'The default sorting order is the first dimension +'Only if sort2ndValue is True the second dimension is the relevant for the sorting order + Dim s as Integer + Dim t as Integer + Dim i as Integer + Dim k as Integer + Dim dimensions as Integer + Dim sortvalue as Integer + Dim DisplayDummy + dimensions = 2 + +On Local Error Goto No2ndDim + k = Ubound(SortList(),2) + No2ndDim: + If Err <> 0 Then dimensions = 1 + + i = Ubound(SortList(),1) + If ismissing(sort2ndValue) then + sortvalue = 0 + else + sortvalue = 1 + end if + + For s = 1 to i - 1 + For t = 0 to i-s + Select Case dimensions + Case 1 + If SortList(t) > SortList(t+1) Then + DisplayDummy = SortList(t) + SortList(t) = SortList(t+1) + SortList(t+1) = DisplayDummy + End If + Case 2 + If SortList(t,sortvalue) > SortList(t+1,sortvalue) Then + For k = 0 to UBound(SortList(),2) + DisplayDummy = SortList(t,k) + SortList(t,k) = SortList(t+1,k) + SortList(t+1,k) = DisplayDummy + Next k + End If + End Select + Next t + Next s + BubbleSortList = SortList() +End Function + + +Function GetValueoutofList(SearchValue, BigList(), iDim as Integer, Optional ValueIndex) +Dim i as Integer +Dim MaxIndex as Integer + MaxIndex = Ubound(BigList(),1) + For i = 0 To MaxIndex + If BigList(i,0) = SearchValue Then + If Not IsMissing(ValueIndex) Then + ValueIndex = i + End If + GetValueOutOfList() = BigList(i,iDim) + End If + Next i +End Function + + +Function AddListtoList(ByVal FirstArray(), ByVal SecondArray(), Optional StartIndex) +Dim n as Integer +Dim m as Integer +Dim MaxIndex as Integer + MaxIndex = Ubound(FirstArray()) + Ubound(SecondArray()) + 1 + If MaxIndex > -1 Then + Dim ResultArray(MaxIndex) + For m = 0 To Ubound(FirstArray()) + ResultArray(m) = FirstArray(m) + Next m + For n = 0 To Ubound(SecondArray()) + ResultArray(m) = SecondArray(n) + m = m + 1 + Next n + AddListToList() = ResultArray() + Else + Dim NullArray() + AddListToList() = NullArray() + End If +End Function + + +Function CheckDouble(DoubleString as String) +On Local Error Goto WRONGDATATYPE + CheckDouble() = CDbl(DoubleString) +WRONGDATATYPE: + If Err <> 0 Then + CheckDouble() = 0 + Resume NoErr: + End If +NOERR: +End Function + diff --git a/wizards/source/tools/UCB.xba b/wizards/source/tools/UCB.xba new file mode 100644 index 000000000..d849a2ea3 --- /dev/null +++ b/wizards/source/tools/UCB.xba @@ -0,0 +1,311 @@ + + + +'Option explicit +Public oDocument +Public oDocInfo as object +Const SBMAXDIRCOUNT = 10 +Dim CurDirMaxCount as Integer +Dim sDirArray(SBMAXDIRCOUNT-1) as String +Dim DirIndex As Integer +Dim iDirCount as Integer +Public bInterruptSearch as Boolean +Public NoArgs()as New com.sun.star.beans.PropertyValue + +Sub Main() +Dim LocsfileContent(0) as String + LocsfileContent(0) = "*" + ReadDirectories("file:///space", LocsfileContent(), True, False, false) +End Sub + +' ReadDirectories( sSourceDir, bRecursive, bCheckRealType, False, sFileContent(), sLocExtension) + +Function ReadDirectories(ByVal AnchorDir As String, bRecursive as Boolean, bcheckFileType as Boolean, bGetByTitle as Boolean, Optional sFileContent(), Optional sExtension as String) +Dim i as integer +Dim Status as Object +Dim FileCountinDir as Integer +Dim RealFileContent as String +Dim FileName as string +Dim oUcbObject as Object +Dim DirContent() +Dim CurIndex as Integer +Dim MaxIndex as Integer +Dim StartUbound as Integer +Dim FileExtension as String + StartUbound = 5 + MaxIndex = StartUBound + CurDirMaxCount = SBMAXDIRCOUNT +Dim sFileArray(StartUbound,1) as String + On Local Error Goto FILESYSTEMPROBLEM: + CurIndex = -1 + ' Todo: Is the last separator valid? + DirIndex = 0 + sDirArray(iDirIndex) = AnchorDir + iDirCount = 1 + oDocInfo = CreateUnoService("com.sun.star.document.DocumentProperties") + oUcbObject = createUnoService("com.sun.star.ucb.SimpleFileAccess") + If oUcbObject.Exists(AnchorDir) Then + Do + AnchorDir = sDirArray(DirIndex) + On Local Error Resume Next + DirContent() = oUcbObject.GetFolderContents(AnchorDir,True) + DirIndex = DirIndex + 1 + On Local Error Goto 0 + On Local Error Goto FILESYSTEMPROBLEM: + If Ubound(DirContent()) <> -1 Then + FileCountinDir = Ubound(DirContent())+ 1 + For i = 0 to FilecountinDir -1 + If bInterruptSearch = True Then + Exit Do + End If + + Filename = DirContent(i) + If oUcbObject.IsFolder(FileName) Then + If brecursive Then + AddFoldertoList(FileName, DirIndex) + End If + Else + If bcheckFileType Then + RealFileContent = GetRealFileContent(FileName) + Else + RealFileContent = GetFileNameExtension(FileName) + End If + If RealFileContent <> "" Then + ' Retrieve the Index in the Array, where a Filename is positioned + If Not IsMissing(sFileContent()) Then + If (FieldInArray(sFileContent(), Ubound(sFileContent), RealFileContent)) Then + ' The extension of the current file passes the filter and is therefore admitted to the + ' fileList + If Not IsMissing(sExtension) Then + If sExtension <> "" Then + ' Consider that some Formats like old StarOffice Templates with the extension ".vor" can only be + ' precisely identified by their mimetype and their extension + FileExtension = GetFileNameExtension(FileName) + If FileExtension = sExtension Then + AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) + End If + Else + AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) + End If + Else + AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) + End If + End If + Else + AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) + End If + If CurIndex = MaxIndex Then + MaxIndex = MaxIndex + StartUbound + ReDim Preserve sFileArray(MaxIndex,1) as String + End If + End If + End If + Next i + End If + Loop Until DirIndex >= iDirCount + If CurIndex > -1 Then + ReDim Preserve sFileArray(CurIndex,1) as String + Else + ReDim sFileArray() as String + End If + Else + Msgbox("Directory '" & ConvertFromUrl(AnchorDir) & "' does not exist!", 16, GetProductName()) + End If + ReadDirectories() = sFileArray() + Exit Function + + FILESYSTEMPROBLEM: + Msgbox("Sorry, Filesystem Problem") + ReadDirectories() = sFileArray() + Resume LEAVEPROC + LEAVEPROC: +End Function + + +Sub AddFoldertoList(sDirURL as String, iDirIndex) + iDirCount = iDirCount + 1 + If iDirCount = CurDirMaxCount Then + CurDirMaxCount = CurDirMaxCount + SBMAXDIRCOUNT + ReDim Preserve sDirArray(CurDirMaxCount) as String + End If + sDirArray(iDirCount-1) = sDirURL +End Sub + + +Sub AddFileNameToList(sFileArray(), FileName as String, FileContent as String, bGetByTitle as Boolean, CurIndex) +Dim FileCount As Integer + CurIndex = CurIndex + 1 + sFileArray(CurIndex,0) = FileName + If bGetByTitle Then + sFileArray(CurIndex,1) = RetrieveDocTitle(oDocInfo, FileName) + ' Add the documenttitles to the Filearray + Else + sFileArray(CurIndex,1) = FileContent + End If +End Sub + + +Function RetrieveDocTitle(oDocProps as Object, sFileName as String) As String +Dim sDocTitle as String + On Local Error Goto NOFILE + oDocProps.loadFromMedium(sFileName, NoArgs()) + sDocTitle = oDocProps.Title + NOFILE: + If Err <> 0 Then + RetrieveDocTitle = "" + RESUME CLR_ERROR + End If + CLR_ERROR: + If sDocTitle = "" Then + sDocTitle = GetFileNameWithoutExtension(sFilename, "/") + End If + RetrieveDocTitle = sDocTitle +End Function + + +' Retrieves The Filecontent of a Document by extracting the content +' from the Header of the document +Function GetRealFileContent(FileName as String) As String + On Local Error Goto NOFILE + oTypeDetect = createUnoService("com.sun.star.document.TypeDetection") + GetRealFileContent = oTypeDetect.queryTypeByURL(FileName) + NOFILE: + If Err <> 0 Then + GetRealFileContent = "" + resume CLR_ERROR + End If + CLR_ERROR: +End Function + + +Function CopyRecursively(SourceFilePath as String, SourceStemDir as String, TargetStemDir as String) +Dim TargetDir as String +Dim TargetFile as String + + TargetFile= ReplaceString(SourceFilePath, TargetStemDir, SourceStemDir) + TargetFileName = FileNameoutofPath(TargetFile,"/") + TargetDir = DeleteStr(TargetFile, TargetFileName) + CreateFolder(TargetDir) + CopyRecursively() = TargetFile +End Function + + +' Opens a help url referenced by a Help ID that is retrieved from the calling button tag +Sub ShowHelperDialog(aEvent) +Dim oSystemNode as Object +Dim sSystem as String +Dim oLanguageNode as Object +Dim sLocale as String +Dim sLocaleList() as String +Dim sLanguage as String +Dim sHelpUrl as String +Dim sDocType as String + HelpID = aEvent.Source.Model.Tag + oLocDocument = StarDesktop.ActiveFrame.Controller.Model + sDocType = GetDocumentType(oLocDocument) + oSystemNode = GetRegistryKeyContent("org.openoffice.Office.Common/Help") + sSystem = oSystemNode.GetByName("System") + oLanguageNode = GetRegistryKeyContent("org.openoffice.Setup/L10N/") + sLocale = oLanguageNode.getByName("ooLocale") + sLocaleList() = ArrayoutofString(sLocale, "-") + sLanguage = sLocaleList(0) + sHelpUrl = "vnd.sun.star.help://" & sDocType & "/" & HelpID & "?Language=" & sLanguage & "&System=" & sSystem + StarDesktop.LoadComponentfromUrl(sHelpUrl, "OFFICE_HELP", 63, NoArgs()) +End Sub + + +Sub SaveDataToFile(FilePath as String, DataList()) +Dim FileChannel as Integer +Dim i as Integer +Dim oFile as Object +Dim oOutputStream as Object +Dim oStreamString as Object +Dim oUcb as Object +Dim sCRLF as String + + sCRLF = CHR(13) & CHR(10) + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + oOutputStream = createUnoService("com.sun.star.io.TextOutputStream") + If oUcb.Exists(FilePath) Then + oUcb.Kill(FilePath) + End If + oFile = oUcb.OpenFileReadWrite(FilePath) + oOutputStream.SetOutputStream(oFile.GetOutputStream) + For i = 0 To Ubound(DataList()) + oOutputStream.WriteString(DataList(i) & sCRLF) + Next i + oOutputStream.CloseOutput() +End Sub + + +Function LoadDataFromFile(FilePath as String, DataList()) as Boolean +Dim oInputStream as Object +Dim i as Integer +Dim oUcb as Object +Dim oFile as Object +Dim MaxIndex as Integer + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + If oUcb.Exists(FilePath) Then + MaxIndex = 10 + oInputStream = createUnoService("com.sun.star.io.TextInputStream") + oFile = oUcb.OpenFileReadWrite(FilePath) + oInputStream.SetInputStream(oFile.GetInputStream) + i = -1 + Redim Preserve DataList(MaxIndex) + While Not oInputStream.IsEOF + i = i + 1 + If i > MaxIndex Then + MaxIndex = MaxIndex + 10 + Redim Preserve DataList(MaxIndex) + End If + DataList(i) = oInputStream.ReadLine + Wend + If i > -1 And i <> MaxIndex Then + Redim Preserve DataList(i) + End If + LoadDataFromFile() = True + oInputStream.CloseInput() + Else + LoadDataFromFile() = False + End If +End Function + + +Function CreateFolder(sNewFolder) as Boolean +Dim oUcb as Object + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + On Local Error Goto NOSPACEONDRIVE + If Not oUcb.Exists(sNewFolder) Then + oUcb.CreateFolder(sNewFolder) + End If + CreateFolder = True +NOSPACEONDRIVE: + If Err <> 0 Then + If InitResources("") Then + ErrMsg = GetResText("RID_COMMON_0") + ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>") + ErrMsg = ReplaceString(ErrMsg, sNewFolder, "%1") + Msgbox(ErrMsg, 48, GetProductName()) + End If + CreateFolder = False + Resume GOON + End If +GOON: +End Function + diff --git a/wizards/source/tools/dialog.xlb b/wizards/source/tools/dialog.xlb new file mode 100644 index 000000000..dc8dfbda2 --- /dev/null +++ b/wizards/source/tools/dialog.xlb @@ -0,0 +1,5 @@ + + + + + diff --git a/wizards/source/tools/script.xlb b/wizards/source/tools/script.xlb new file mode 100644 index 000000000..fe4d74d60 --- /dev/null +++ b/wizards/source/tools/script.xlb @@ -0,0 +1,10 @@ + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/tutorials/Functions.xba b/wizards/source/tutorials/Functions.xba new file mode 100644 index 000000000..4b422c80b --- /dev/null +++ b/wizards/source/tutorials/Functions.xba @@ -0,0 +1,385 @@ + + + +REM ***** BASIC ***** +Dim DialogVisible As Boolean +Dim TutorStep As Integer +Dim TutorLastStep As Integer +Dim myDialog As Object +Dim myTutorial As Object +Public TutorText() As String +Dim documentTitle As String +Dim exampleUse As Object +Dim properties() As Object +Dim docTYP As String +'public myWidth As Long +Dim myHeight As Long +Dim oTextField As Object +Dim stepTitle As String +Dim oOpenDialogFlag +Dim imageStatus As String + +Sub LoadTutorialDialog(exampleToUse, documentTYP) + Init() + exampleUse = exampleToUse + TutorText() = exampleUse.LoadText() + properties() = exampleUse.GetProperties() + If properties(3).Value = "True" Then + Dim localisation(0) As new com.sun.star.beans.NamedValue + localisation(0).Name = "Localisation" + localisation(0).Value = properties() + myTutorial.execute(localisation()) + Else + TutorStep = 0 + TutorLastStep = 0 + docTYP = documentTYP + InitAction() + ShowInfoMain() + DialogVisible = True + myDialog = LoadDialog("Tutorials","TutorialsDialog") + + SetTutorialDocumentPosSize() + + documentProps = ThisComponent.getDocumentProperties() + myDialog.Title = "Tutorials - " & documentProps.Title + oTextField = myDialog.GetControl("myTextField") + oTextField.setVisible(False) + + imageStatus = "MIN" + setMaxMinImage(imageStatus) + + 'myWidth = myDialog.Size.Width + myHeight = myDialog.Size.Height + + CheckForStepShowButtonStatus() + CheckForStepNextButtonStatus() + InitRoadMap() + SetVisibleTrue() + myDialog.model.myTextField.Label = stepTitle + myDialog.model.myText.Label = GetStepText()'TutorText(TutorStep) + + + Do + wait 1000 + Loop Until DialogVisible = False + If( oOpenDialogFlag = True) Then + Destroy() + TutorialOpen.TutorialOpenMain() + Else + Destroy() + End If + End If +End Sub + +Sub setMaxMinImage(param As String) + On Local Error Goto NOIMAGE + oCommandButton = myDialog.GetControl("CommandButton") + templatePath = GetPathSettings("Template",false, 0) + Dim bitmapPath As String + iPos = InStr(templatePath,"/") + If(iPos > 0) Then + If(param = "MAX") Then + bitmapPath = templatePath & "../wizard/bitmap/maximize.png" + ElseIf(param = "MIN") Then + bitmapPath = templatePath & "../wizard/bitmap/minimize.png" + End If + Else + If(param = "MAX") Then + bitmapPath = templatePath & "..\wizard\bitmap\maximize.png" + ElseIf(param = "MIN") Then + bitmapPath = templatePath & "..\wizard\bitmap\minimize.png" + End If + End If + 'printdbgInfo oCommandButton.Model + oCommandButton.Model.ImageUrl = bitmapPath + Exit Sub + NOIMAGE: +End Sub + +Sub SetTutorialDocumentPosSize() + activDesktopWindow = StarDesktop.activeFrame.ContainerWindow + If(activDesktopWindow.posSize.Height < 550) Then + activDesktopWindow.setPosSize(0,0,0,550,8) + End If + If (activDesktopWindow.posSize.Width < 750 ) Then + activDesktopWindow.setPosSize(0,0,750,0,4) + EndIf +End Sub + +Sub InitRoadMap() + RoadMapMain(Functions, myDialog) + SetControlModelPosSize(0, 0, 85, 176) + SetControlModelText("Steps") + + StepSize = Ubound(TutorText()) + Dim ItemsArray(StepSize) as String + For i = 0 To StepSize + stepcontent = TutorText(i) + iPos = InStr(stepcontent,CHR(13)) + ItemName = Left(stepcontent, iPos) + ItemsArray(i) = ItemName + Next i + InsertItemsLabels( ItemsArray()) + + For i = 1 To StepSize + SetItemEnabled( i, False) + Next i + SetItemEnabled( 0, True) +End Sub + +Sub Destroy() + 'myDialog.dispose + wait 1000 + ShowInfoDialog.DisposeIDialog() + + ' THE DOCUMENT GETS CLOSED HERE!!!!!!!! GPF + thisComponent.CurrentController.Frame.close(True) + +End Sub + +Sub Init + GlobalScope.BasicLibraries.LoadLibrary("Tools") + myTutorial = createUNOService("com.sun.star.wizards.tutorial.executer.CallTutorialFramework") + documentTitle = ThisComponent.getCurrentController.getFrame.Title +End Sub + +Sub InitStep + udProps = ThisComponent.DocumentProperties.UserDefinedProperties + If udProps.PropertySetInfo.hasPropertyByName("CurrentStep") Then + TutorStep = udProps.CurrentStep + Else + udProps.addProperty("CurrentStep", 0, TutorStep) + End If +End Sub + +Sub setStep + ThisComponent.DocumentProperties.UserDefinedProperties.CurrentStep = TutorStep +End Sub + +Sub InitAction() + SetStepTitle() + + Dim property(6) As new com.sun.star.beans.PropertyValue + property(0).Name = "DocumentTYP" + property(0).Value = docTYP + property(1).Name = "MethodName" + property(1).Value = "setDelay" + property(2).Name = "Param" + property(2).Value = 0 'key insert speed (Millis) + property(3).Name = "Param" + property(3).Value = 4 'mouse animate speed (Millis) + property(4).Name = "Param" + property(4).Value = 2000 'after mouse animate sleep (Millis) + property(5).Name = "Param" + property(5).Value = 10 'mouse scroll speed (Millis) + property(6).Name = "Param" + property(6).Value = -1 'mouse speed (step) + myTutorial.setPropertyValues(property()) +End Sub + +Sub EndDialog + oOpenDialogFlag = False + If (myDialog.model.done.Label = "Close") Then + TutorialCloseMain() + Else + DialogVisible = False + End If +End Sub + +Sub NextStep + GotoStep(TutorStep + 1) +End Sub + +Sub GotoStep(StepIndex) + If(StepIndex <= Ubound(TutorText())) Then + TutorStep = StepIndex + If TutorStep > TutorLastStep Then + TutorLastStep = TutorStep + End If + If(TutorStep = Ubound(TutorText())) Then + myDialog.model.next.enabled = False + myDialog.model.done.Label = "Done" + myDialog.model.show.Label = "Tutorials" + Else + myDialog.model.next.enabled = True + End If + SetStepTitle() + myDialog.model.myText.Label = GetStepText() + CheckForStepShowButtonStatus() + SetItemEnabled( TutorStep, True) + 'setStep() + End If +End Sub + +Function GetStepText() + Dim tempText As String + tempText = TutorText(TutorStep) + iPos = InStr(tempText,CHR(13)) + ResultString = Right(tempText, Len(tempText) - iPos - 1) + GetStepText() = ResultString +End Function + +Sub ItemChange(CurrentItemID, SelectitemID) + GotoStep(SelectitemID) +End Sub + +Sub SetDisableShowMeButton() + myDialog.model.show.enabled = False + TutorLastStep = TutorLastStep + 1 +End Sub + +Sub Minimize(aEvent) + ActionItemsTextField = myDialog.GetControl("ActionItemsLabel") + FixedLineVertikal = myDialog.GetControl("FixedLineVertikal") + + If myDialog.Size.Height = 35 Then + myDialog.setPosSize(0,0,0,myHeight,8) + oTextField.setVisible(False) + ActionItemsTextField.setVisible(True) + FixedLineVertikal.setVisible(True) + RoadMap.SetVisibleRoadMap(True) + Else + myDialog.setPosSize(0,0,0,35,8) + rmSelectedIndex = RoadMap.GetSelectedIndex() + 1 + gsTitle = GetStepTitle() + oTextField.setText(rmSelectedIndex & ". " & gsTitle) + oTextField.setVisible(True) + ActionItemsTextField.setVisible(False) + FixedLineVertikal.setVisible(False) + RoadMap.SetVisibleRoadMap(False) + End If + If(imageStatus = "MAX") Then + imageStatus = "MIN" + ElseIf(imageStatus = "MIN") Then + imageStatus = "MAX" + End If + setMaxMinImage(imageStatus) + +End Sub + +Sub SetStepTitle() + stepcontent = TutorText(TutorStep) + iPos = InStr(stepcontent,CHR(13)) + stepTitle = Left(stepcontent, iPos) + SetStepTitle() = stepTitle +End Sub + +Function GetStepTitle() + GetStepTitle() = stepTitle +End Function + +Sub CheckForStepShowButtonStatus() + If ((exampleUse.ContainsStepAction() = True And TutorStep = TutorLastStep) Or myDialog.model.show.Label = "Tutorials") Then + myDialog.model.show.enabled = True + Else + myDialog.model.show.enabled = False + End If +End Sub + +Sub CheckForStepNextButtonStatus() + If(TutorStep = Ubound(TutorText())) Then + myDialog.model.next.enabled = False + myDialog.model.done.Label = "Done" + End If +End Sub + +Sub Show(aEvent) + 'ShowInfoMain() + If( myDialog.model.show.Label = "Tutorials") Then + oOpenDialogFlag = True + DialogVisible = False + Else + SetMousePosition(aEvent) + exampleUse.Action() + End If +End Sub + +Sub SetMousePosition(aEvent) + MyPoints() = MousePoints(aEvent) + + Dim mousePosition(3) as new com.sun.star.beans.PropertyValue + mousePosition(0).Name = "DocumentTYP" + mousePosition(0).Value = docTYP + mousePosition(1).Name = "MethodName" + mousePosition(1).Value = "setMousePosition" + mousePosition(2).Name = "Param" + mousePosition(2).Value = MyPoints(0) + mousePosition(3).Name = "Param" + mousePosition(3).Value = MyPoints(1) + + myTutorial.setPropertyValues(mousePosition()) +End Sub + +Function MousePoints(aEvent) + Dim position(1) As Integer + position(0) = myDialog.getControl("show").AccessibleContext.LocationOnScreen.X + aEvent.Source.Model.PositionX + position(1) = myDialog.getControl("show").AccessibleContext.LocationOnScreen.Y + aEvent.Source.Model.PositionY + MousePoints = position() +End Function + +Function CheckPath(path() As String) + 'documentTitle = ThisComponent.getCurrentController.getFrame.Title + sTitle = path(0) + ResultString = Right(sTitle, 3) + iPos = InStr(ResultString,"#") + ResultString = Right(ResultString, Len(ResultString) - iPos) + ResultFrameString = InStr (sTitle, "{D}FRAME#") + If ResultFrameString <> 0 Then + If Not (sTitle = ("{D}FRAME#" & documentTitle & "#" & ResultString)) Then + 'path(0) = "{D}FRAME#" & documentTitle & "#" & ResultString + path(0) = "FRAME#" & documentTitle & "#" & ResultString + sTitle = path(1) + ResultString = Right(sTitle, 3) + iPos = InStr(ResultString,"#") + ResultString = Right(ResultString, Len(ResultString) - iPos) + path(1) = "ROOT_PANE#" & documentTitle & "#" & ResultString + Else + 'path(0) = "{D}FRAME#" & documentTitle & "#" & ResultString + path(0) = "FRAME#" & documentTitle & "#" & ResultString + End If + End If +End Function + +Sub SetVisibleTutorialsDialog(param) + myDialog.setVisible(param) +End Sub + +Sub SetVisibleTrue() + myDialog.setVisible(True) +End Sub + +Sub SetVisibleFalse() + myDialog.setVisible(False) +End Sub + +Sub ExitTutorial() + Dim aUrl As new com.sun.star.util.URL + oDoc = ThisComponent + urlTransformer = createUNOService("com.sun.star.util.URLTransformer") + aUrl.Complete = "slot:5621" + urlTransformer.parseStrict(aUrl) + xController = oDoc.getCurrentController() + xDispatcher = xController.queryDispatch(aUrl, "", 0) + if NOT isNull(xDispatcher) then + xDispatcher.dispatch(aUrl, DimArray()) + else + msgBox "Error! Cannot close document." + End If +End Sub + diff --git a/wizards/source/tutorials/RoadMap.xba b/wizards/source/tutorials/RoadMap.xba new file mode 100644 index 000000000..efcfc03a4 --- /dev/null +++ b/wizards/source/tutorials/RoadMap.xba @@ -0,0 +1,134 @@ + + + +REM ***** BASIC ***** +Dim oControlModel +Dim oDialogModel +Dim CurrentItem +Dim bLongString +Dim oControl +Dim oEvent +Dim oUseDialog As Object +Dim oModulName As Object + +Sub RoadMapMain(ModulNameforItemChange, dialogtoUse) + GlobalScope.BasicLibraries.LoadLibrary("Tools") + oUseDialog = dialogtoUse + oModulName = ModulNameforItemChange + oDialogModel = oUseDialog.Model + oControlModel = oUseDialog.Model.CreateInstance("com.sun.star.awt.UnoControlRoadmapModel") + + oDialogModel.insertByName("RoadMap", oControlModel) + oControl = oUseDialog.getControl("RoadMap") + oEvent = createUnoListener( "CallBack_", "com.sun.star.awt.XItemListener" ) + oControl.addItemListener(oEvent) + oControlModel.CurrentItemID = 0 + oControlModel.Complete = True + oControlModel.Activated = True +End Sub + +Sub SetVisibleRoadMap(param) + oControl.SetVisible(param) +End Sub + +Sub SetDialogModelSize(Width, Height) + oDialogModel.Width = Width + oDialogModel.Height = Height +End Sub + +Sub SetControlModelPosSize(X, Y, Width, Height) + oControlModel.PositionX = X + oControlModel.PositionY = Y + oControlModel.Width = Width + oControlModel.Height = Height +End Sub + +Sub SetControlModelText( ModelText As String) + oControlModel.Text = ModelText +End Sub + +Sub InsertItemsLabels( ItemLabelsArray() As String) + For i = 0 To Ubound(ItemLabelsArray()) + oRoadmapItem = oControlModel.createInstance() + oRoadmapItem.Label = ItemLabelsArray(i) + oRoadmapItem.ID = i + oControlModel.insertbyIndex(i, oRoadmapItem) + Next i +End Sub + +Sub SetItemEnabled( ItemIndex, param) + oControlModel.getByIndex(ItemIndex).Enabled = param + oControlModel.CurrentItemID = ItemIndex +End Sub + +Sub AddImagetoControlModel( Url As String) + oControlModel.ImageUrl = ConvertToUrl(Url) +End Sub + +Function GetSelectedIndex() + GetSelectedIndex() = oControlModel.CurrentItemID +End Function + +Function GetControlModel() + GetControlModel = oControlModel +End Function + +Function GetDialogModel() + GetDialogModel = oDialogModel +End Function + +Sub Callback_itemStateChanged(aEvent) + oModulName.ItemChange(oControlModel.CurrentItemID, aEvent.itemID) +End Sub + +Sub SetComplete(param) + oControlModel.Complete = param +End Sub + +Sub SetActivated(param) + oControlModel.Activated = param +End Sub + +Sub RemoveItem(ItemIndex) + If ItemIndex > -1 Then + oControlModel.removeByIndex(ItemIndex) + End If +End Sub + +Sub InsertItem(ItemLabel As String) + oRoadmapItem = oControlModel.createInstance() + oRoadmapItem.Label = ItemLabel + oControlModel.insertbyIndex(oControlModel.CurrentItemID, oRoadmapItem) +End Sub + +Sub ReplaceItem(ItemLabel As String) + oRoadmapItem = oControlModel.createInstance() + oRoadmapItem.Label = ItemLabel + oControlModel.replacebyIndex(oControlModel.CurrentItemID, oRoadmapItem) +End Sub + +Sub Callback_disposing(aEvent) +End Sub + +Sub Property_propertyChange(aEvent) +End Sub + +Sub Property_disposing(aEvent) +End Sub + \ No newline at end of file diff --git a/wizards/source/tutorials/ShowInfoDialog.xba b/wizards/source/tutorials/ShowInfoDialog.xba new file mode 100644 index 000000000..e1da4b596 --- /dev/null +++ b/wizards/source/tutorials/ShowInfoDialog.xba @@ -0,0 +1,322 @@ + + + +REM ***** BASIC ***** +Dim oWnd As Object +Dim oWnd2 As Object +Dim oWnd3 As Object +Dim oDoc as Object + +Sub ShowInfoMain + prop() = GetShowInfoProperties() + Init(prop(0).Value, prop(1).Value, prop(2).Value, prop(3).Value, prop(4).Value, prop(5).Value, prop(6).Value, prop(7).Value, prop(8).Value) +End Sub + +Sub Init(tFieldText As String, windowX, windowY, windowWidth, windowHeight, tFieldX, tFieldY, tFieldWidth, tFieldHeight) + toolkit = createUnoService("com.sun.star.awt.Toolkit") + Dim oWndDescr As new com.sun.star.awt.WindowDescriptor + Dim oBounds As new com.sun.star.awt.Rectangle + oWndDescr.Type = com.sun.star.awt.WindowClass.TOP + oWndDescr.WindowServiceName = "" + oWndDescr.ParentIndex = 0 + + 'officeX = StarDesktop.ActiveFrame.getContainerWindow().AccessibleContext.LocationOnScreen.X + 'officeY = StarDesktop.ActiveFrame.getContainerWindow().AccessibleContext.LocationOnScreen.Y + 'officeWidth = StarDesktop.ActiveFrame.getContainerWindow().getPosSize().Width + 'officeHeight = StarDesktop.ActiveFrame.getContainerWindow().getPosSize().Height + officeWidth = thisComponent.CurrentController.Frame.getContainerWindow().getPosSize().Width + officeHeight = thisComponent.CurrentController.Frame.getContainerWindow().getPosSize().Height + + 'dialogWidth = myTutoShowDialog.getPosSize().Width + 'dialogHeight = myTutoShowDialog.getPosSize().Height + X = officeWidth - windowWidth - windowX + Y = officeHeight - windowHeight - windowY + + oBounds.X = X : oBounds.Y = Y + oBounds.Width = windowWidth : oBounds.Height = windowHeight + oWndDescr.Bounds = oBounds + oWndDescr.Parent = thisComponent.CurrentController.Frame.ContainerWindow + with com.sun.star.awt.WindowAttribute + oWndDescr.WindowAttributes = .CLOSEABLE AND .MOVEABLE AND .SIZEABLE AND .BORDER AND .SHOW + end with + + oWnd = toolkit.createWindow(oWndDescr) + + Dim oWndDescr3 As new com.sun.star.awt.WindowDescriptor + Dim oBounds3 As new com.sun.star.awt.Rectangle + oWndDescr3.Type = com.sun.star.awt.WindowClass.TOP + oWndDescr3.WindowServiceName = "fixedimage" '"fixedtext" + oWndDescr3.ParentIndex = 0 + oBounds3.X = 0 : oBounds3.Y = 0 + oBounds3.Width = tFieldWidth : oBounds3.Height = tFieldHeight + oWndDescr3.Bounds = oBounds3 + oWndDescr3.Parent = oWnd + with com.sun.star.awt.WindowAttribute + oWndDescr3.WindowAttributes = .CLOSEABLE AND .MOVEABLE AND .SIZEABLE AND .BORDER AND .SHOW + end with + + oWnd3= toolkit.createWindow(oWndDescr3) + 'oWnd2.Text = tFieldText + 'printdbgInfo(oWnd3) + setImage(oWnd3) + 'oWnd3.Background = 16777215 +' oWnd2.SetBackGround(16776960) + oWnd.SetBackGround(16776960) +' oWnd.FontDescriptors(0).Name = "Albany" +' oWnd.FontDescriptors(0).StyleName = "BOLD" + + Dim oWndDescr2 As new com.sun.star.awt.WindowDescriptor + Dim oBounds2 As new com.sun.star.awt.Rectangle + oWndDescr2.Type = com.sun.star.awt.WindowClass.TOP + oWndDescr2.WindowServiceName = "fixedtext" + oWndDescr2.ParentIndex = 0 + oBounds2.X = tFieldX : oBounds2.Y = tFieldY + oBounds2.Width = tFieldWidth : oBounds2.Height = tFieldHeight + oWndDescr2.Bounds = oBounds2 + oWndDescr2.Parent = oWnd3 + with com.sun.star.awt.WindowAttribute + oWndDescr2.WindowAttributes = .CLOSEABLE AND .MOVEABLE AND .SIZEABLE AND .BORDER AND .SHOW + end with + + oWnd2= toolkit.createWindow(oWndDescr2) + oWnd2.Text = tFieldText + oWnd2.Background = 268435455 + 'printdbgInfo(oWnd2) + + 'printdbgInfo oWnd.getPosSize() + +End Sub + +Function GetShowInfoProperties() + stepText = GetStepTitle() + Dim Properties(8) As new com.sun.star.beans.NamedValue + Properties(0).Name = "ShowInfoDialogText" + Properties(0).Value = stepText & "Press [Esc] to abort." + Properties(1).Name = "WindowX" + Properties(1).Value = 20 + Properties(2).Name = "WindowY" + Properties(2).Value = 40 + Properties(3).Name = "WindowWidth" + Properties(3).Value = 190 + Properties(4).Name = "WindowHeight" + Properties(4).Value = 50 + Properties(5).Name = "TFieldX" + Properties(5).Value = 7 + Properties(6).Name = "TFieldY" + Properties(6).Value = 8 + Properties(7).Name = "TFieldWidth" + Properties(7).Value = 190 + Properties(8).Name = "TFieldHeight" + Properties(8).Value = 50 + GetShowInfoProperties = Properties() +End Function + +Sub setShowInfoText() + stepText = GetStepTitle() + oWnd2.Text = stepText & "Press [Esc] to abort." +End Sub + +Sub ShowON() + setShowInfoText() + oWnd.setVisible(True) + oWnd3.setVisible(True) + oWnd2.setVisible(True) +End Sub + +Sub ShowOFF() + 'On Local Error Goto NOPROPERTYSETINFO: + oWnd.setVisible(False) + oWnd2.setVisible(False) + oWnd3.setVisible(False) + 'oDoc.dispose() + Exit Sub + 'NOPROPERTYSETINFO: +End Sub + +Sub DisposeIDialog() + 'On Local Error Goto NOPROPERTYSETINFO: + oWnd3.dispose + oWnd2.dispose + oWnd.dispose + oDoc.dispose() + Exit Sub + 'NOPROPERTYSETINFO: +End Sub + +sub setImage(whatever as Object) + + templatePath = GetPathSettings("Template",false, 0) + Dim bitmapPath As String + iPos = InStr(templatePath,"/") + if(iPos > 0) Then + bitmapPath = templatePath & "../wizard/bitmap/tutorial_background.gif" + Else + bitmapPath = templatePath & "..\wizard\bitmap\tutorial_background.gif" + End If + + dim props(0) as new com.sun.star.beans.PropertyValue + props(0).Name = "Hidden" + props(0).Value = true + oDoc = StarDesktop.loadComponentFromUrl("private:factory/swriter","_blank",0,props()) + oShape = addControlToDefaultForm("ImageButton", 1000, 1000, 2000, 1000) + imgControl = oShape.getControl() + 'imgControl.ImageUrl="file:///D:/Program%20Files/src680_m11_qwizards1_49_TEST/share/gallery/tutoItem.gif" + imgControl.ImageUrl = bitmapPath + imgControl.addConsumer(whatever) + imgControl.startProduction() +end sub + +Function createControlShape(cKind As String) As Object + + Dim oControlShape As Object + Dim oControl As Object + + + oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape") + oControl = oDoc.createInstance("com.sun.star.form.component." & cKind) + oControl.setPropertyValue("DefaultControl", "com.sun.star.form.control." & cKind) + oControlShape.setControl(oControl) + + + createControlShape() = oControlShape + +End Function + +Function createControlShapeWithDefaultControl(cKind As String) As Object + + Dim oControlShape As Object + Dim oControl As Object + + + oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape") + oControl = oDoc.createInstance("com.sun.star.form.component." & cKind) + oControlShape.setControl(oControl) + + + createControlShapeWithDefaultControl() = oControlShape + +End Function + +Function createUNOControlShape(cKind As String, defControl As String) As Object + + Dim oControlShape As Object + Dim oControl As Object + + + oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape") + oControl = oDoc.createInstance("com.sun.star.form.component." & cKind) + oControl.setPropertyValue("DefaultControl", "com.sun.star.awt." & defControl) + oControlShape.setControl(oControl) + + + createUNOControlShape() = oControlShape + +End Function + +Function addShape(oShape As Object) As Boolean + + Dim vSize As New com.sun.star.awt.Size + Dim oDrawPage As Object + Dim oForms As Object + Dim oForm As Object + + oDrawPage = oDoc.getDrawPage() + oForms = oDrawPage.getForms() + + if oForms.Count = 0 then + oForm = oDoc.createInstance("com.sun.star.form.component.Form") + oForms.insertByIndex(0, oForm) + end if + + vSize.Height = 2000 : vSize.Width = 2000 + oShape.Size = vSize + oDrawPage.add(oShape) + + addShape() = true + +End Function + +sub addControl(cKind as String) + + Dim oDrawPage As Object + Dim oForm As Object, oForms As Object + Dim oControl As Object, oControlShape As Object + Dim aSz As Variant + Dim oText As Object + + oDrawPage = oDoc.DrawPage + oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape") + oControl = oDoc.createInstance("com.sun.star.form.component." + cKind) + oForm = oDoc.createInstance("com.sun.star.form.component.Form") + oforms = oDrawPage.Forms + if oforms.count = 0 then + oforms.insertbyindex(0,oForm) + end if + oControlShape.Control = oControl + oDrawPage.add(oControlShape) + +End sub + +Function addControlToDefaultForm(cKind as String, x As Integer, y As Integer, width As Integer, height As Integer) As Object + + Dim oDrawPage As Object + Dim oControl As Object, oControlShape As Object + Dim pos As New com.sun.star.awt.Point + Dim size As New com.sun.star.awt.Size + + pos.X = x + pos.Y = y + size.Width = width + size.Height = height + + oDrawPage = oDoc.DrawPage + oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape") + oControl = oDoc.createInstance("com.sun.star.form.component." + cKind) + oControlShape.Control = oControl + oControlShape.Position = pos + oControlShape.Size = size + oDrawPage.add(oControlShape) + + addControlToDefaultForm() = oControlShape + +End Function + +Function addShapeToDrawDoc(oPage as Object, nPosX, nPosY as Integer, oType As String) As Object + Dim aPoint As New com.sun.star.awt.Point + Dim aSize As New com.sun.star.awt.Size + Dim oShape As Object + Dim servNames As Variant + + aPoint.x = nPosX + aPoint.y = nPosY + aSize.Width = 2000 + aSize.Height = 1000 + oShape = oDoc.createInstance("com.sun.star.drawing."+oType+"Shape") + oShape.Size = aSize + oShape.Position = aPoint + + if oShape.getPropertySetInfo().hasPropertyByName("FillColor") then + oShape.FillColor = RGB(128, 255, 0) + End If + + oPage.add(oShape) + + addShapeToDrawDoc() = oShape +End Function + diff --git a/wizards/source/tutorials/TutorialClose.xba b/wizards/source/tutorials/TutorialClose.xba new file mode 100644 index 000000000..b4a066b89 --- /dev/null +++ b/wizards/source/tutorials/TutorialClose.xba @@ -0,0 +1,32 @@ + + + +REM ***** BASIC ***** +Dim myCloseDialog As Object + +Sub TutorialCloseMain + myCloseDialog = LoadDialog("Tutorials","TutorialCloseDialog") + myCloseDialog.Execute() +End Sub + +Sub CloseYes(aEvent) + myCloseDialog.EndExecute() + DialogVisible = False +End Sub + \ No newline at end of file diff --git a/wizards/source/tutorials/TutorialCloseDialog.xdl b/wizards/source/tutorials/TutorialCloseDialog.xdl new file mode 100644 index 000000000..a362b2a44 --- /dev/null +++ b/wizards/source/tutorials/TutorialCloseDialog.xdl @@ -0,0 +1,31 @@ + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/tutorials/TutorialCreator.xba b/wizards/source/tutorials/TutorialCreator.xba new file mode 100644 index 000000000..34e1276f4 --- /dev/null +++ b/wizards/source/tutorials/TutorialCreator.xba @@ -0,0 +1,27 @@ + + + +REM ***** BASIC ***** +Sub TutorialCreatorMain + GlobalScope.BasicLibraries.LoadLibrary("Tools") + myTutorial = createUNOService("com.sun.star.wizards.tutorial.executer.CallTutorialFramework") + myTutorial.trigger("StartTutorialCreator") +End Sub + + \ No newline at end of file diff --git a/wizards/source/tutorials/TutorialOpen.xba b/wizards/source/tutorials/TutorialOpen.xba new file mode 100644 index 000000000..5b6001c6c --- /dev/null +++ b/wizards/source/tutorials/TutorialOpen.xba @@ -0,0 +1,113 @@ + + + +REM ***** BASIC ***** +Dim myOpenDialog As Object +Dim oListBox As Object +Dim files As Object +Dim oUcb As Object +Dim oListener As Object + +Sub TutorialOpenMain + GlobalScope.BasicLibraries.LoadLibrary("Tools") + myOpenDialog = LoadDialog("Tutorials","TutorialOpenDialog") + init() + myOpenDialog.Execute() +End Sub + +Sub Init + On Local Error Goto NOFILE + myOpenDialog.Title = "Tutorials" + oListBox = myOpenDialog.GetControl("ListBox") + templatePath = GetPathSettings("Template",false, 0) + Dim tutorialPath As String + iPos = InStr(templatePath,"/") + if(iPos > 0) Then + tutorialPath = templatePath & "/tutorials" + Else + tutorialPath = templatePath & "\tutorials" + End If + oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") + files = oUcb.getFolderContents(tutorialPath,true) + size = Ubound( files() ) + Dim tempFiles(size) As String + tempCount = 0 + For iCount = 0 To size + completPath = files(iCount) + oDocInfo = CreateUnoService("com.sun.star.document.DocumentProperties") + oDocInfo.Read(completPath) + sDocTitle = oDocInfo.Title + if(not isNull(sDocTitle) And len(sDocTitle) > 0) Then + oListbox.addItem(sDocTitle,0) + tempFiles(tempCount) = completPath + tempCount = tempCount + 1 + End If + Next iCount + 'printdbgInfo oListbox + size = oListbox.ItemCount - 1 + Dim tempFiles2(size) As String + For iCount = 0 To size + tempFiles2(iCount) = tempFiles(iCount) + Next iCount + files() = tempFiles2() + Exit Sub + NOFILE: + If Err <> 0 Then + Msgbox "No file found error!" & CHR(13) & "Path: ...\share\template\...\tutorials\" + myOpenDialog.model.Open.enabled = False + End If +End Sub + +Sub ItemSelected(oEvent) + On Local Error Goto NOFILE + completPath = files(Ubound(files()) - oEvent.Selected) + oTextField = myOpenDialog.GetControl("Label") 'TextField + oTextField.setText("") + Dim NoArgs() as new com.sun.star.beans.PropertyValue + oDocInfo = CreateUnoService("com.sun.star.document.DocumentProperties") + oDocInfo.Read(completPath) + sDocDescription = oDocInfo.Description + if(not isNull(sDocTitle) And len(sDocDescription) > 0) Then + oTextField.setText(sDocDescription) + Else + oTextField.setText("Not Description!!!.") + End If + Exit Sub + NOFILE: + If Err <> 0 Then + Msgbox "Open file error!" + End If +End Sub + +Sub OpenTutorial(aEvent) + completPath = files(Ubound(files()) - oListBox.getSelectedItemPos()) + Dim Args(2) as new com.sun.star.beans.PropertyValue + Args(1).Name = "MacroExecutionMode" + Args(1).Value = com.sun.star.document.MacroExecMode.ALWAYS_EXECUTE + Args(2).Name = "AsTemplate" + Args(2).Value = true + + StarDesktop.LoadComponentFromURL(completPath,"_default",0, Args()) + myOpenDialog.endExecute() +End Sub + +Sub Cancel(aEvent) + myOpenDialog.endExecute() +End Sub + \ No newline at end of file diff --git a/wizards/source/tutorials/TutorialOpenDialog.xdl b/wizards/source/tutorials/TutorialOpenDialog.xdl new file mode 100644 index 000000000..d9a6009a3 --- /dev/null +++ b/wizards/source/tutorials/TutorialOpenDialog.xdl @@ -0,0 +1,38 @@ + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/tutorials/TutorialsDialog.xdl b/wizards/source/tutorials/TutorialsDialog.xdl new file mode 100644 index 000000000..f8a2ee211 --- /dev/null +++ b/wizards/source/tutorials/TutorialsDialog.xdl @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/wizards/source/tutorials/dialog.xlb b/wizards/source/tutorials/dialog.xlb new file mode 100644 index 000000000..e02b20688 --- /dev/null +++ b/wizards/source/tutorials/dialog.xlb @@ -0,0 +1,7 @@ + + + + + + + \ No newline at end of file diff --git a/wizards/source/tutorials/script.xlb b/wizards/source/tutorials/script.xlb new file mode 100644 index 000000000..30280c6b1 --- /dev/null +++ b/wizards/source/tutorials/script.xlb @@ -0,0 +1,10 @@ + + + + + + + + + + \ No newline at end of file -- cgit v1.2.3