[Libreoffice-commits] core.git: scp2/source wizards/Module_wizards.mk wizards/Package_access2base.mk wizards/source
Jean-Pierre Ledure
jp at ledure.be
Sun Oct 13 16:28:48 PDT 2013
scp2/source/ooo/directory_ooo.scp | 5
scp2/source/ooo/file_ooo.scp | 7
scp2/source/ooo/module_hidden_ooo.scp | 1
wizards/Module_wizards.mk | 1
wizards/Package_access2base.mk | 55
wizards/source/access2base/Application.xba | 1080 +++++++++++++
wizards/source/access2base/Collect.xba | 215 ++
wizards/source/access2base/Compatible.xba | 47
wizards/source/access2base/Control.xba | 2185 +++++++++++++++++++++++++++
wizards/source/access2base/DataDef.xba | 424 +++++
wizards/source/access2base/Database.xba | 523 ++++++
wizards/source/access2base/Dialog.xba | 667 ++++++++
wizards/source/access2base/DoCmd.xba | 2034 +++++++++++++++++++++++++
wizards/source/access2base/Event.xba | 487 ++++++
wizards/source/access2base/Field.xba | 738 +++++++++
wizards/source/access2base/Form.xba | 821 ++++++++++
wizards/source/access2base/L10N.xba | 279 +++
wizards/source/access2base/Methods.xba | 268 +++
wizards/source/access2base/OptionGroup.xba | 300 +++
wizards/source/access2base/PropertiesGet.xba | 1148 ++++++++++++++
wizards/source/access2base/PropertiesSet.xba | 511 ++++++
wizards/source/access2base/Property.xba | 134 +
wizards/source/access2base/Recordset.xba | 1053 +++++++++++++
wizards/source/access2base/SubForm.xba | 540 ++++++
wizards/source/access2base/Test.xba | 19
wizards/source/access2base/Trace.xba | 415 +++++
wizards/source/access2base/Utils.xba | 647 +++++++
wizards/source/access2base/_License.xba | 22
wizards/source/access2base/acConstants.xba | 346 ++++
wizards/source/access2base/dialog.xlb | 6
wizards/source/access2base/dlgFormat.xdl | 19
wizards/source/access2base/dlgTrace.xdl | 32
wizards/source/access2base/script.xlb | 28
wizards/source/configshare/dialog.xlc | 3
wizards/source/configshare/script.xlc | 1
35 files changed, 15060 insertions(+), 1 deletion(-)
New commits:
commit 350772317dd0bd226c33b1945f3801fcb146891b
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sat Oct 12 10:56:41 2013 +0200
Access2Base store (wizards + scp2)
License text modified after gerrit review
Change-Id: I193d6d1fd477cca4c2880760f21f8d978643f634
Reviewed-on: https://gerrit.libreoffice.org/6232
Reviewed-by: Lionel Elie Mamane <lionel at mamane.lu>
Tested-by: Lionel Elie Mamane <lionel at mamane.lu>
diff --git a/scp2/source/ooo/directory_ooo.scp b/scp2/source/ooo/directory_ooo.scp
index ded453f..4bda27e 100644
--- a/scp2/source/ooo/directory_ooo.scp
+++ b/scp2/source/ooo/directory_ooo.scp
@@ -255,6 +255,11 @@ Directory gid_Dir_Basic
DosName = "basic";
End
+Directory gid_Dir_Basic_Access2Base
+ ParentID = gid_Dir_Basic;
+ DosName = "Access2Base";
+End
+
Directory gid_Dir_Basic_Euro
ParentID = gid_Dir_Basic;
DosName = "Euro";
diff --git a/scp2/source/ooo/file_ooo.scp b/scp2/source/ooo/file_ooo.scp
index 3177769..ec76fac 100644
--- a/scp2/source/ooo/file_ooo.scp
+++ b/scp2/source/ooo/file_ooo.scp
@@ -27,6 +27,13 @@
#include "macros.inc"
+File gid_File_Basic_Access2Base
+ Dir = FILELIST_DIR;
+ TXT_FILE_BODY;
+ Styles = (FILELIST);
+ Name = "wizards_basicsrvaccess2base.filelist";
+End
+
File gid_File_Basic_Depot
Dir = FILELIST_DIR;
TXT_FILE_BODY;
diff --git a/scp2/source/ooo/module_hidden_ooo.scp b/scp2/source/ooo/module_hidden_ooo.scp
index 928cd0c..22edd6c 100644
--- a/scp2/source/ooo/module_hidden_ooo.scp
+++ b/scp2/source/ooo/module_hidden_ooo.scp
@@ -265,6 +265,7 @@ Module gid_Module_Root_Files_6
gid_File_Scripts_Java,
gid_File_Scripts_Java_jars,
gid_File_Scripts_Javascript,
+ gid_File_Basic_Access2Base,
gid_File_Basic_Depot,
gid_File_Basic_Euro,
gid_File_Basic_Form,
diff --git a/wizards/Module_wizards.mk b/wizards/Module_wizards.mk
index fd05f39..0a7438a 100644
--- a/wizards/Module_wizards.mk
+++ b/wizards/Module_wizards.mk
@@ -25,6 +25,7 @@ $(eval $(call gb_Module_add_targets,wizards,\
AllLangResTarget_imp \
AllLangResTarget_tpl \
AllLangResTarget_wzi \
+ Package_access2base \
Package_depot \
Package_euro \
Package_form \
diff --git a/wizards/Package_access2base.mk b/wizards/Package_access2base.mk
new file mode 100644
index 0000000..d6a0e17
--- /dev/null
+++ b/wizards/Package_access2base.mk
@@ -0,0 +1,55 @@
+# -*- Mode: makefile-gmake; tab-width: 4; indent-tabs-mode: t -*-
+#
+# 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 .
+#
+
+$(eval $(call gb_Package_Package,wizards_basicsrvaccess2base,$(SRCDIR)/wizards/source/access2base))
+
+$(eval $(call gb_Package_set_outdir,wizards_basicsrvaccess2base,$(INSTROOT)))
+
+$(eval $(call gb_Package_add_files,wizards_basicsrvaccess2base,$(LIBO_SHARE_FOLDER)/basic/Access2Base,\
+ _License.xba \
+ acConstants.xba \
+ Application.xba \
+ Collect.xba \
+ Compatible.xba \
+ Control.xba \
+ Database.xba \
+ DataDef.xba \
+ Dialog.xba \
+ dialog.xlb \
+ dlgFormat.xdl \
+ dlgTrace.xdl \
+ DoCmd.xba \
+ Event.xba \
+ Field.xba \
+ Form.xba \
+ L10N.xba \
+ Methods.xba \
+ OptionGroup.xba \
+ PropertiesGet.xba \
+ PropertiesSet.xba \
+ Property.xba \
+ Recordset.xba \
+ script.xlb \
+ SubForm.xba \
+ Test.xba \
+ Trace.xba \
+ Utils.xba \
+))
+
+# vim: set noet sw=4 ts=4:
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba
new file mode 100644
index 0000000..680c546
--- /dev/null
+++ b/wizards/source/access2base/Application.xba
@@ -0,0 +1,1080 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
+<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Application" script:language="StarBasic">Option Explicit
+
+'DATABASE
+' Name property
+' Path property
+
+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 ERRNOTDATABASE = 1501
+Global Const ERRDBNOTCONNECTED = 1502
+Global Const ERRMISSINGARGUMENTS = 1503
+Global Const ERRWRONGARGUMENT = 1504
+Global Const ERRMAINFORM = 1505
+Global Const ERRSTANDALONE = 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 ERRMETHOD = 1531
+Global Const ERRPROPERTYINIT = 1532
+Global Const ERRFILENOTCREATED = 1533
+Global Const ERRDIALOGNOTFOUND = 1534
+Global Const ERRDIALOGUNDEFINED = 1535
+Global Const ERRDIALOGSTARTED = 1536
+Global Const ERRDIALOGNOTSTARTED = 1537
+Global Const ERRRECORDSETNODATA = 1538
+Global Const ERRRECORDSETCLOSED = 1539
+Global Const ERRRECORDSETRANGE = 1540
+Global Const ERRRECORDSETFORWARD = 1541
+Global Const ERRFIELDNULL = 1542
+Global Const ERRFILEACCESS = 1543
+Global Const ERRMEMOLENGTH = 1544
+Global Const ERRNOTACTIONQUERY = 1545
+Global Const ERRNOTUPDATABLE = 1546
+Global Const ERRUPDATESEQUENCE = 1547
+Global Const ERRNOTNULLABLE = 1548
+Global Const ERRROWDELETED = 1549
+Global Const ERRRECORDSETCLONE = 1550
+Global Const ERRQUERYDEFDELETED = 1551
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Global Const COLLALLDIALOGS = "ALLDIALOGS"
+Global Const COLLALLFORMS = "ALLFORMS"
+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"
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Global Const OBJAPPLICATION = "APPLICATION"
+Global Const OBJCOLLECTION = "COLLECTION"
+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 OBJOPTIONGROUP = "OPTIONGROUP"
+Global Const OBJPROPERTY = "PROPERTY"
+Global Const OBJQUERYDEF = "QUERYDEF"
+Global Const OBJRECORDSET = "RECORDSET"
+Global Const OBJSUBFORM = "SUBFORM"
+Global Const OBJTABLEDEF = "TABLEDEF"
+
+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 -----------------------------------------------------------------------------------------------------------------------
+Type Root
+ ' Single values
+ ErrorHandler As Boolean
+ MinimalTraceLevel As Integer
+ TraceLogs() As Variant
+ TraceLogCount As Integer
+ TraceLogLast As Integer
+ TraceLogMaxEntries As Integer
+ CalledSub As String
+ Introspection As Object ' com.sun.star.beans.Introspection
+ VersionNumber As String ' Actual Access2Base version number
+ CurrentDb() As Object ' Array of database objects -{0] = Base file, [1..N] = Writer files
+End Type
+
+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
+Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
+Const cstCount = 0
+Const cstByIndex = 1
+Const cstByName = 2
+Const cstSepar = "!"
+
+ If IsMissing(pvIndex) Then
+ iMode = cstCount
+ Else
+ If Not Utils.Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
+ End If
+
+ Set vAllDialogs = Nothing
+
+ Set oDocLibraries = ThisComponent.DialogLibraries '_CurrentDb().Document.DialogLibraries
+ vDocLibraries = oDocLibraries.getElementNames()
+ Set oMacLibraries = DialogLibraries
+ vMacLibraries = oMacLibraries.getElementNames()
+ 'Remove Access2Base from the list
+ For i = 0 To UBound(vMacLibraries)
+ If vMacLibraries(i) = "Access2Base" Then vMacLibraries(i) = ""
+ Next i
+ vMacLibraries = Utils._TrimArray(vMacLibraries)
+
+ If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library
+ Set vAllDialogs = New Collect
+ vAllDialogs._CollType = COLLALLDIALOGS
+ vAllDialogs._ParentType = OBJAPPLICATION
+ vAllDialogs._ParentName = ""
+ 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)
+ 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)
+ 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
+ vAllDialogs._CollType = COLLALLDIALOGS
+ vAllDialogs._ParentType = OBJAPPLICATION
+ vAllDialogs._ParentName = ""
+ 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
+ vAllDialogs._Name = vDialogs(j)
+ vAllDialogs._Shortcut = "Dialogs!" & vDialogs(j)
+ Set vAllDialogs._Dialog = oLibDialog
+ End If
+
+Exit_Function:
+ Set AllDialogs = vAllDialogs
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+Trace_Not_Found:
+ TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils.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
+
+If _ErrorHandler() Then On Local Error Goto Error_Function
+Const cstThisSub = "AllForms"
+ Utils._SetCalledSub(cstThisSub)
+Dim iIndex As Integer, vAllForms As Variant
+ Set vAllForms = Nothing
+
+ If Not IsMissing(pvIndex) Then
+ If Not Utils.Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ Select Case VarType(pvIndex)
+ Case vbString
+ iIndex = -1
+ Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
+ iIndex = pvIndex
+ End Select
+ End If
+
+Dim oDatabase As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object
+ Set oDatabase = _CurrentDb()
+ If Not oDatabase._Standalone Then Set oForms = oDatabase.Document.getFormDocuments()
+' Process when NO ARGUMENT
+ If IsMissing(pvIndex) Then ' No argument
+ Set oCounter = New Collect
+ oCounter._CollType = COLLALLFORMS
+ oCounter._ParentType = OBJAPPLICATION
+ oCounter._ParentName = ""
+ If oDatabase._Standalone Then oCounter._Count = 1 Else oCounter._Count = oForms.getCount()
+ Set vAllForms = oCounter
+ Goto Exit_Function
+ End If
+
+' Process when ARGUMENT = STRING or INDEX => Initialize form object
+Dim ofForm As Object
+ Set ofForm = New Form
+Dim sAllForms As Variant, i As Integer, sSub As String, vName As Variant
+ Select Case oDatabase._Standalone
+ Case False
+ sAllForms() = oForms.getElementNames()
+ If iIndex= -1 Then ' String argument
+ vName = Utils._InList(Utils.Utils._Trim(pvIndex), sAllForms, True) ' hasByName not used because case sensitive
+ If vName = False Then Goto Trace_Not_Found
+ ofForm._Initialize(vName)
+ Else
+ If iIndex + 1 > oForms.getCount() Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense
+ ofForm._Initialize(sAllForms(iIndex))
+ End If
+ Case True
+ If iIndex = -1 Then
+ If UCase(Utils.Utils._Trim(pvIndex)) <> UCase(oDatabase.FormName) Then Goto Trace_Not_Found
+ ElseIf iIndex <> 0 Then
+ Goto Trace_Error_Index
+ End If
+ vName = oDatabase.FormName
+ ofForm._Initialize(vName)
+ End Select
+
+ Set vAllForms = ofForm
+
+Exit_Function:
+ Set AllForms = vAllForms
+ 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 vAllForms = Nothing
+ Goto Exit_Function
+Error_Function:
+ TraceError(TRACEABORT, Err, cstThisSub, Erl)
+ Set vAllForms = Nothing
+ GoTo Exit_Function
+End Function ' AllForms V0.9.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, vEMPTY As variant
+Const cstThisSub = "Controls"
+ Utils._SetCalledSub(cstThisSub)
+
+ If IsMissing(pvObject) Then Call _TraceArguments()
+ If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
+ Controls = vEMPTY
+
+ 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.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(Optional pvURL As String) As Object
+' Returns _A2B_.CurrentDb(.) as an object to allow access to its properties
+' Parameter only for internal use
+
+Const cstThisSub = "CurrentDb"
+ Utils._SetCalledSub(cstThisSub)
+Dim i As Integer, bFound As Boolean, sURL As String, oCurrent As Object
+
+ bFound = False
+ Set CurrentDb = Nothing
+ With _A2B_
+ If Not IsArray(.CurrentDb) Then Goto Exit_Function
+ If UBound(.CurrentDb) < 0 Then Goto Exit_Function
+ For i = 1 To UBound(.CurrentDb) ' [0] reserved to database .odb document
+ Set oCurrent = .CurrentDb(i)
+ If IsMissing(pvURL) Then ' Not on 1 single line ?!?
+ If Utils.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 .CurrentDb(i).URL = sURL Then
+ Set CurrentDb = oCurrent
+ bFound = True
+ Exit For
+ End If
+ Next i
+ If Not bFound Then
+ If Not IsNull(.CurrentDb(0)) Then Set CurrentDb = .CurrentDb(0)
+ End If
+ End With
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+End Function ' CurrentDb V0.9.5
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function CurrentUser() As String
+
+Const cstWindows = 1
+Const cstUnix = 4
+ Select Case GetGuiType()
+ Case cstWindows
+ CurrentUser = Environ("USERNAME")
+ Case cstUnix
+ CurrentUser = Environ("USER")
+ Case Else
+ CurrentUser = ""
+ End Select
+
+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._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._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._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._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._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._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._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._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._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._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.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, Utils.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
+ oCounter._CollType = COLLFORMS
+ oCounter._ParentType = OBJAPPLICATION
+ oCounter._ParentName = ""
+ oCounter._Count = iCount
+ Forms = oCounter
+ Exit Function
+ Else
+ If Not Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ End If
+
+ Select Case VarType(pvIndex)
+ Case vbString
+ Set ofForm = Application.AllForms(Utils.Utils._Trim(pvIndex))
+ Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
+ iCount = Application._CountOpenForms()
+ If iCount <= pvIndex Then Goto Trace_Error_Index
+ Set ofForm = Application._CountOpenForms(pvIndex)
+ Case Else
+ 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, , 1)
+ 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 Sub OpenConnection ( _
+ Optional pvComponent As Variant _
+ , ByVal Optional pvUser As Variant _
+ , ByVal Optional pvPassword As Variant _
+ )
+
+' 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) form (V0.8.0)
+' Call template:
+' Call OpenConnection(ThisComponent[, "", ""])
+' Call stored in the OpenDocument event of the standalone form
+
+Dim odbDatabase As Variant, oComponent As Object, oForm As Object, iCurrent As Integer
+Dim i As Integer, bFound As Boolean
+Dim vCurrentDb() As Variant
+
+ If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
+
+ If _ErrorHandler() Then On Local Error Goto Error_Sub
+Const cstThisSub = "OpenConnection"
+ Utils._SetCalledSub(cstThisSub)
+ If IsMissing(pvComponent) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Sub
+ Set oComponent = pvComponent
+ If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 1)
+ Exit Sub
+ End If
+ If IsMissing(pvUser) Then pvUser = ""
+ If IsMissing(pvPassword) Then pvPassword = ""
+ If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Sub
+ If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Sub
+
+ If Not IsArray(_A2B_.CurrentDb) Then vCurrentDb = Array() Else vCurrentDb = _A2B_.CurrentDb
+
+ Set odbDatabase = New Database
+ Select Case oComponent.ImplementationName
+ Case "com.sun.star.comp.dba.ODatabaseDocument"
+ If Not oComponent.CurrentController.IsConnected Then oComponent.CurrentController.Connect(pvUser, pvPassword)
+ Set odbDatabase.Connection = oComponent.CurrentController.ActiveConnection
+ odbDatabase._Standalone = False
+ Case "SwXTextDocument"
+ Set oForm = oComponent.CurrentController.Model.DrawPage.Forms
+ If oForm.Count <> 1 Then Goto Error_MainForm
+ odbDatabase.FormName = oForm.ElementNames(0)
+ odbDatabase.Form = oForm.getByName(odbDatabase.FormName)
+ Set odbDatabase.Connection = odbDatabase.Form.ActiveConnection
+ odbDatabase._Standalone = True
+ Case Else
+ TraceError(TRACEFATAL, ERRNOTDATABASE, Utils._CalledSub(), 0, , 1)
+ End Select
+
+ If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist
+ Set odbDatabase.MetaData = odbDatabase.Connection.MetaData
+ End If
+ Set odbDatabase.Document = oComponent
+ odbDatabase.Title = oComponent.Title
+ odbDatabase.URL = oComponent.URL
+
+ If UBound(vCurrentDb) < 0 Then ' NOT ON 1 SINGLE LINE !!!
+ Redim vCurrentDb(0 To 0)
+ End If
+
+ Select Case odbDatabase._Standalone ' Find entry to use for new connection
+ Case True
+ If UBound(vCurrentDb) <= 0 Then
+ iCurrent = 1
+ Else ' Search entry already used earlier by same component
+ bFound = False
+ For i = 1 To UBound(vCurrentDb)
+ If Not IsEmpty(vCurrentDb(i)) Then
+ If vCurrentDb(i)._Standalone And vCurrentDb(i).URL = odbDatabase.URL Then
+ iCurrent = i
+ bFound = True
+ Exit For
+ End If
+ End If
+ Next i
+ End If
+ If Not bFound Then
+ iCurrent = UBound(vCurrentDb) + 1 ' No entry found, increment array
+ ReDim Preserve vCurrentDb(0 To iCurrent)
+ End If
+ Set vCurrentDb(iCurrent) = odbDatabase
+ Case False
+ Set vCurrentDb(0) = odbDatabase
+ End Select
+
+ _A2B_.CurrentDb = vCurrentDb
+
+ TraceLog(TRACEANY, Utils._GetProductName() & " - Access2Base " & _A2B_.VersionNumber, False)
+ If IsNull(odbDatabase.Connection) Then Goto Trace_Error
+ TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False)
+
+Exit_Sub:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Sub
+Error_Sub:
+ TraceError(TRACEABORT, Err, cstThisSub, Erl)
+ Set _A2B_.CurrentDb = Array()
+ GoTo Exit_Sub
+Error_MainForm:
+ TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title)
+ Set _A2B_.CurrentDb = Array()
+ GoTo Exit_Sub
+Trace_Error:
+ TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
+ Goto Exit_Sub
+End Sub ' OpenConnection V0.9.1
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function ProductCode()
+ ProductCode = "Access2Base " & _A2B_.VersionNumber
+End Function ' ProductCode V0.9.1
+
+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
+
+Const cstThisSub = "SysCmd"
+ Utils._SetCalledSub(cstThisSub)
+ SysCmd = False
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+
+Const cstMissing = -1
+Const cstBarLength = 350
+ If IsMissing(pvAction) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvAction, 1, Utils.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.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, oDb As Object, iLen As Integer
+ Set oDb = _CurrentDb()
+ Set vBar = oDb.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 oDb.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 oDb.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 Version() As String
+ Version = Utils._GetProductName()
+End Function ' Version V0.9.1
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- PRIVATE FUNCTIONS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+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
+ Set ofForm = New Form
+ 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 V0.9.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _CurrentDb() As Variant
+REM Same as CurrentDb() except that it generates an error if database not connected (internal use)
+
+Dim odbDatabase As Variant
+ Set odbDatabase = Application.CurrentDb()
+ 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
+
+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
+
+ vResult = Null
+
+ If psFunction = "" Then sExpr = "TOP 1 " & psExpr Else sExpr = UCase(psFunction) & "(" & psExpr & ")"
+
+ sSql = "SELECT " & sExpr & " AS XXRESULTFIELDXX FROM " & psDomain
+ If pvCriteria <> "" Then
+ sSql = sSql & " WHERE " & pvCriteria
+ End If
+ If pvOrderClause <> "" Then
+ sSql = sSql & " ORDER BY " & pvOrderClause
+ End If
+ sSql = Utils._ReplaceSquareBrackets(sSql) 'Substitute [] by quote string
+
+ 'Lookup the value.
+Dim oDatabase As Object
+ Set oStatement = _CurrentDb.Connection.createStatement()
+ With oStatement
+ .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
+ .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
+ .EscapeProcessing = False
+ 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)
+ End If
+ End With
+
+Exit_Function:
+ 'Assign the returned value.
+ _DFunction = vResult
+ Set oResult = Nothing
+ Set oStatement = Nothing
+ Exit Function
+Error_Function:
+ TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
+ Goto Exit_Function
+End Function ' DFunction V0.9.5
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _NewBar() As Object
+' Close current status bar, if any, and initialize new one
+
+Dim vBar As Variant, vWindow As Variant, oDb As Object, vController As Object
+ On Local Error Resume Next
+ Set _NewBar = Nothing
+
+ Set oDb = Application._CurrentDb()
+ Set vBar = oDb.StatusBar
+ If Not IsNull(vBar) Then
+ If Utils._hasUNOMethod(vBar, "end") Then vBar.end()
+ Set oDb.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 ' 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 oDb.StatusBar = vBar
+ Set _NewBar = vBar
+ Exit Function
+
+End Function ' _NewBar V0.9.1
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Sub _RootInit()
+' Initialize _A2B_ global variable
+
+Dim vRoot As Root
+ If IsEmpty(_A2B_) Then
+ _A2B_ = vRoot
+ With _A2B_
+ .VersionNumber = Access2Base_Version
+ .ErrorHandler = True
+ .MinimalTraceLevel = 0
+ .TraceLogs() = Array()
+ .TraceLogCount = 0
+ .TraceLogLast = 0
+ .TraceLogMaxEntries = 0
+ .CalledSub = ""
+ .Introspection = Nothing
+ End With
+ End If
+
+End Sub ' _RootInit V0.9.1
+</script:module>
\ 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 0000000..43cd91a
--- /dev/null
+++ b/wizards/source/access2base/Collect.xba
@@ -0,0 +1,215 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
+<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Collect" script:language="StarBasic">Option Compatible
+Option ClassModule
+
+Option Explicit
+
+REM MODULE NAME <> COLLECTION (seems a reserved name ?)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CLASS ROOT FIELDS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+Private _Type As String ' Must be COLLECTION
+Private _CollType As String
+Private _ParentType As String
+Private _ParentName As String ' Name or shortcut
+Private _Count As Long
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CONSTRUCTORS / DESTRUCTORS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Sub Class_Initialize()
+ _Type = OBJCOLLECTION
+ _CollType = ""
+ _ParentType = ""
+ _ParentName = ""
+ _Count = 0
+End Sub ' Constructor
+
+REM -----------------------------------------------------------------------------------------------------------------------
+'Private Sub Class_Terminate()
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CLASS GET/LET/SET PROPERTIES ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+Property Get Count() As Long
+ Count = _PropertyGet("Count")
+End Property ' Count (get)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get Item(ByVal Optional pvItem As Variant) As Variant
+'Return property value.
+'pvItem either numeric index or property name
+
+Const cstThisSub = "Collection.getItem"
+ Utils._SetCalledSub(cstThisSub)
+ If IsMissing(pvItem) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
+
+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 COLLCONTROLS
+ Select Case _ParentType
+ Case OBJCONTROL, OBJSUBFORM
+ Set Item = getObject(_ParentName).Controls(pvItem)
+ Case OBJDIALOG
+ Set Item = Application.AllDialogs(_ParentName).Controls(pvItem)
+ Case OBJFORM
+ Set Item = Application.Forms(_ParentName).Controls(pvItem)
+ Case OBJOPTIONGROUP
+ ' NOT SUPPORTED
+ End Select
+ Case COLLFORMS
+ Set Item = Application.Forms(pvItem)
+ Case COLLFIELDS
+ Select Case _ParentType
+ Case OBJQUERYDEF
+ Set Item = Application.CurrentDb().QueryDefs(_ParentName).Fields(pvItem)
+ Case OBJRECORDSET
+ Set Item = Application.CurrentDb().Recordsets(_ParentName).Fields(pvItem)
+ Case OBJTABLEDEF
+ Set Item = Application.CurrentDb().TableDefs(_ParentName).Fields(pvItem)
+ End Select
+ Case COLLPROPERTIES
+ Select Case _ParentType
+ Case OBJCONTROL, OBJSUBFORM
+ Set Item = getObject(_ParentName).Properties(pvItem)
+ Case OBJDATABASE
+ Set Item = Application.CurrentDb().Properties(pvItem)
+ Case OBJDIALOG
+ Set Item = Application.AllDialogs(_ParentName).Properties(pvItem)
+ Case OBJFIELD
+ vNames() = Split(_ParentName, "/")
+ Select Case vNames(0)
+ Case OBJQUERYDEF
+ Set Item = Application.CurrentDb().QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
+ Case OBJRECORDSET
+ Set Item = Application.CurrentDb().Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem)
+ Case OBJTABLEDEF
+ Set Item = Application.CurrentDb().TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
+ End Select
+ Case OBJFORM
+ Set Item = Application.Forms(_ParentName).Properties(pvItem)
+ Case OBJQUERYDEF
+ Set Item = Application.CurrentDb().QueryDefs(_ParentName).Properties(pvItem)
+ Case OBJRECORDSET
+ Set Item = Application.CurrentDb().Recordsets(_ParentName).Properties(pvItem)
+ Case OBJTABLEDEF
+ Set Item = Application.CurrentDb().TableDefs(_ParentName).Properties(pvItem)
+ Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP
+ ' NOT SUPPORTED
+ End Select
+ Case COLLQUERYDEFS
+ Set Item = Application.CurrentDb().QueryDefs(pvItem)
+ Case COLLRECORDSETS
+ Set Item = Application.CurrentDb().Recordsets(pvItem)
+ Case COLLTABLEDEFS
+ Set Item = Application.CurrentDb().TableDefs(pvItem)
+ Case Else
+ End Select
+
+Exit_Function:
+ Exit Property
+Error_Function:
+ TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
+ Set Item = Nothing
+ GoTo Exit_Function
+End Property ' V0.9.5
+
+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, _ParentName, vPropertiesList)
+ Else
+ vProperty = PropertiesGet._Properties(sObject, _ParentName, 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 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 -----------------------------------------------------------------------------------------------------------------------
+REM --- PRIVATE FUNCTIONS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+Private Function _PropertiesList() As Variant
+ _PropertiesList = Array("Count", "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("ObjectType")
+ _PropertyGet = _Type
+ Case Else
+ Goto Trace_Error
+ End Select
+
+Exit_Function:
+ Utils._ResetCalledSub("Collection.get" & psProperty)
+ Exit Function
+Trace_Error:
+ TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
+ _PropertyGet = Nothing
+ Goto Exit_Function
+Error_Function:
+ TraceError(TRACEABORT, Err, "Collection._PropertyGet", Erl)
+ _PropertyGet = Nothing
+ GoTo Exit_Function
+End Function ' _PropertyGet
+
+
+</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Compatible.xba b/wizards/source/access2base/Compatible.xba
new file mode 100644
index 0000000..1e26300
--- /dev/null
+++ b/wizards/source/access2base/Compatible.xba
@@ -0,0 +1,47 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
+<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Compatible" script:language="StarBasic">Option Compatible
+Option Explicit
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Sub DebugPrint(ParamArray pvArgs() As Variant)
+
+'Print arguments unconditionnally 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))
+
+ If UBound(pvArgs) >= 0 Then
+ For i = 0 To UBound(pvArgs)
+' If IsError(pvArgs(i)) Then ' IsError gives "Object variable not set" in LO 4,0 ?!?
+' pvArgs(i) = "[ERROR]"
+' Else
+ If Not Utils._CheckArgument(pvArgs(i), i + 1, vVarTypes(), , False) Then pvArgs(i) = "[TYPE?]"
+' End If
+ Next i
+ End If
+
+Dim sOutput As String, sArg As String
+ sOutput = ""
+ For i = 0 To UBound(pvArgs)
+ sArg = Utils._CStr(pvArgs(i))
+ ' 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
+</script:module>
\ 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 0000000..b922416
--- /dev/null
+++ b/wizards/source/access2base/Control.xba
@@ -0,0 +1,2185 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
+<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Control" script:language="StarBasic">Option Compatible
+Option ClassModule
+
+Option Explicit
+
+REM -----------------------------------------------------------------------------------------------------------------------
+REM --- CLASS ROOT FIELDS ---
+REM -----------------------------------------------------------------------------------------------------------------------
+
+Private _Type As String ' Must be CONTROL
+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 _ControlType As Integer
+Private _SubType As String
+Private ControlModel As Object ' com.sun.star.comp.forms.XXXModel
+Private ControlView As Object ' com.sun.star.comp.forms.XXXControl
+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
+ _ClassId = -1
+ _ParentType = ""
+ _Shortcut = ""
+ _Name = ""
+ _SubType = ""
+ Set ControlModel = Nothing
+ Set ControlView = Nothing
+ Set BoundField = Nothing
+ Set LabelControl = Nothing
+
+End Sub ' Constructor
+
+REM -----------------------------------------------------------------------------------------------------------------------
+'Private Sub Class_Terminate()
+
+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 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 -----------------------------------------------------------------------------------------------------------------------
+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, _Shortcut, vPropertiesList)
+ Else
+ vProperty = PropertiesGet._Properties(sObject, _Shortcut, 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 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
+
+If _ErrorHandler() Then On Local Error Goto Error_Function
+ Utils._SetCalledSub("Grid.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, 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
+ oCounter._CollType = COLLCONTROLS
+ oCounter._ParentType = OBJCONTROL
+ oCounter._ParentName = _Shortcut
+ 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
+ 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
+
+ ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name)
+ Set ocControl.ControlModel = ControlModel.getByName(ocControl._Name)
+ ocControl._ImplementationName = ocControl.ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !?
+ ocControl._FormComponent = ParentComponent
+ If Utils._hasUNOProperty(ocControl.ControlModel, "ClassId") Then ocControl._ClassId = ocControl.ControlModel.ClassId
+ ' Complex bypass to find View of grid subcontrols !
+ For i = 0 to ControlView.getCount() - 1
+ Set oView = ControlView.GetByIndex(i)
+ If oView.getModel.Name = ocControl._Name Then
+ Set ocControl.ControlView = oView
+ Exit For
+ End If
+ Next i
+
+ ocControl._Initialize()
+ Set Controls = ocControl
+
+Exit_Function:
+ Utils._ResetCalledSub("Grid.Controls")
+ Exit Function
+Trace_Error:
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1)
+ 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, vObject._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, "Grid.Controls", 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
+ ReDim Preserve vRowSource(0 To iCount - 1)
+ 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
+ bFound = True
+ For i = pvIndex To iCount - 1
+ vRowSource(i) = vRowSource(i + 1)
+ Next i
+ ReDim Preserve vRowSource(0 To iCount - 1)
+ End Select
+
+ If bFound Then
+ 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)
+ RemoveItem = False
+ Goto Exit_Function
+Error_Index:
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,2)
+ 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)
+ 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 _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 -----------------------------------------------------------------------------------------------------------------------
+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 -----------------------------------------------------------------------------------------------------------------------
+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.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
+ vFullPropertiesList = Array( _
+ "BackColor" _
+ , "BorderColor" _
+ , "BorderStyle" _
+ , "Cancel" _
+ , "Caption" _
+ , "ControlSource" _
+ , "ControlTipText" _
+ , "ControlType" _
+ , "Default" _
+ , "DefaultValue" _
+ , "Enabled" _
+ , "FontBold" _
+ , "FontItalic" _
+ , "FontName" _
+ , "FontSize" _
+ , "FontUnderline" _
+ , "FontWeight" _
+ , "ForeColor" _
+ , "Form" _
... etc. - the rest is truncated
More information about the Libreoffice-commits
mailing list