LibreOffice logo
BASEDOCUMENTER
The software tool for documenting your LibreOffice Base applications
 
Database file/home/jean-pierre/Documents/BaseDocumenter/www/databases/Basic/Access2Base.odb
File actual save date2018-07-08 15:24:40
Scanning done on2018-07-08 14:33:10
Documentation generated on2018-07-29 18:22:30
Table of contents
Access2Base
Procedures by module
Library Module name Procedure name Language Used by Number of code lines Procedure code
Access2BaseDev acConstants vbCr Basic vbNewLine (Procedure)
_Initialize (Procedure)
3
REM New Lines
REM -----------------------------------------------------------------
Public Function vbCr() As String : vbCr = Chr(13) : End Function
Access2BaseDev acConstants vbLf Basic vbNewLine (Procedure)
_PropValuesToStr (Procedure)
Lines (Procedure)
_FindPattern (Procedure)
_Initialize (Procedure)
_LineOfPosition (Procedure)
1
Public Function vbLf() As String	:	vbLf = Chr(10)	:	End Function
Access2BaseDev acConstants vbNewLine Basic TraceConsole (Procedure)
_ReadAll (Procedure)
_FindPattern (Procedure)
4
Public Function vbNewLine() As String
Const cstWindows = 1
If GetGuiType() = cstWindows Then vbNewLine = vbCR & vbLF Else vbNewLine = vbLF
End Function ' vbNewLine V1.4.0
Access2BaseDev acConstants vbTab Basic _Trim (Procedure)
_FindPattern (Procedure)
1
Public Function vbTab() As String	:	vbTab = Chr(9)	:	End Function
Access2BaseDev Application _CountOpenForms Basic Forms (Procedure) 24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CountOpenForms(ByVal Optional piCountMax As Integer) As Variant
' Return # of active forms if no argument
' Return name of piCountMax-th open form if argument present

Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant
iAllCount = AllForms._Count
iCount = 0
If iAllCount > 0 Then
For i = 0 To iAllCount - 1
Set ofForm = Application.AllForms(i)
If ofForm.IsLoaded Then iCount = iCount + 1
If Not IsMissing(piCountMax) Then
If iCount = piCountMax + 1 Then
_CountOpenForms = ofForm ' OO3.2 aborts when Set verb present ?!?
Exit For
End If
End If
Next i
End If

If IsMissing(piCountMax) Then _CountOpenForms = iCount

End Function ' CountOpenForms V1.1.0
Access2BaseDev Application _CurrentDb Basic DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
OpenForm (Procedure)
OutputTo (Procedure)
Quit (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
_OpenObject (Procedure)
Delete (Procedure)
mClose (Procedure)
CurrentDb (Procedure)
_Initialize (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant
REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use)
REM With 2 arguments return the corresponding entry in Root

Dim oCurrentDb As Object
If IsEmpty(_A2B_) Then GoTo Trace_Error
If IsMissing(piDocEntry) Then Set oCurrentDb = Application.CurrentDb() _
Else Set oCurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry)
If IsNull(oCurrentDb) Then Goto Trace_Error Else Set _CurrentDb = oCurrentDb

Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1)
Goto Exit_Function
End Function ' _CurrentDb V1.1.0
Access2BaseDev Application _NewBar Basic SysCmd (Procedure) 34
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _NewBar() As Object
' Close current status bar, if any, and initialize new one

Dim vBar As Variant, vWindow As Variant, vController As Object
On Local Error Resume Next
Set _NewBar = Nothing

Set vBar = _A2B_.StatusBar
If Not IsNull(vBar) Then
If Utils._hasUNOMethod(vBar, "end") Then vBar.end()
Set _A2B_.StatusBar = Nothing
End If

Set vBar = Nothing
Set vWindow = _SelectWindow()
If IsNull(vWindow.Frame) Then Exit Function
Select Case vWindow.WindowType
Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow
Case Else
Exit Function
End Select
If Utils._hasUNOMethod(vWindow.Frame, "getCurrentController") Then
Set vController = vWindow.Frame.getCurrentController()
ElseIf Utils._hasUNOMethod(vWindow.Frame, "getController") Then
Set vController = vWindow.Frame.getController()
End If

If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator()
Set _A2B_.StatusBar = vBar
Set _NewBar = vBar
Exit Function

End Function ' _NewBar V1.1.0
Access2BaseDev Application _NewCommandBar Basic CommandBars (Procedure) 28
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _NewCommandBar(psModule As String _
, psToolbarName As String _
, psToolbarFullName As String _
, piBuiltin As Integer _
) As Object

Dim oObject As Object
Set oObject = New CommandBar
With oObject
._Type = OBJCOMMANDBAR
._Name = psToolbarName
._ResourceURL = psToolbarFullName
._Module = psModule
._BarBuiltin = piBuiltin
Select Case UCase(Split(psToolbarFullName, "/")(1))
Case "MENUBAR" : ._BarType = msoBarTypeMenuBar
Case "STATUSBAR" : ._BarType = msoBarTypeStatusBar
Case "TOOLBAR" : ._BarType = msoBarTypeNormal
Case "POPUP" : ._BarType = msoBarTypePopup
Case "FLOATER" : ._BarType = msoBarTypeFloater
Case Else : ._BarType = -1
End Select
End With
Set _NewCommandBar = oObject
Exit Function

End Function ' NewCommandBar V1.3.0
Access2BaseDev Application _RootInit Basic OpenConnection (Procedure)
OpenDatabase (Procedure)
ProductCode (Procedure)
TraceError (Procedure)
_ErrorHandler (Procedure)
_ResetCalledSub (Procedure)
_SetCalledSub (Procedure)
8
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _RootInit(Optional ByVal pbForce As Boolean)
' Initialize _A2B_ global variable. Reinit forced if pbForce = True

If IsMissing(pbForce) Then pbForce = False
If IsEmpty(_A2B_) Or pbForce Then _A2B_ = New Root_

End Sub ' _RootInit V1.1.0
Access2BaseDev Application AllDialogs Basic Item (Procedure)
getObject (Procedure)
132
REM -----------------------------------------------------------------------------------------------------------------------
Public Function AllDialogs(ByVal Optional pvIndex As Variant) As Variant
' Return either a Collection or a Dialog object
' The dialogs are selected only if library is loaded

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "AllDialogs"
Utils._SetCalledSub(cstThisSub)

Dim iMode As Integer, vDialogs() As Variant, i As Integer, j As Integer, iCount As Integer
Dim oMacLibraries As Object, vAllDialogs As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean
Dim oLibDialog As Object, sLibrary As String, oDocLibraries As Object, bLocalStorage As Boolean
Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
Dim vCurrentDocument As Variant
Const cstCount = 0
Const cstByIndex = 1
Const cstByName = 2
Const cstSepar = "!"

If IsMissing(pvIndex) Then
iMode = cstCount
Else
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
End If

Set vAllDialogs = Nothing

Set vCurrentDocument = _A2B_.CurrentDocument
If IsNull(vCurrentDocument) Then
Set oDocLibraries = Nothing
vDocLibraries = Array()
Else
Set oDocLibraries = _A2B_.CurrentDocument.Document.DialogLibraries ' ThisComponent.DialogLibraries
vDocLibraries = oDocLibraries.getElementNames()
End If
Set oMacLibraries = DialogLibraries
vMacLibraries = oMacLibraries.getElementNames()
'Remove Access2Base from the list
If _A2B_.ExcludeA2B Then
For i = 0 To UBound(vMacLibraries)
If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
Next i
End If
vMacLibraries = Utils._TrimArray(vMacLibraries)

If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library
Set vAllDialogs = New Collect
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)
bLocalStorage = True
Set oDocMacLib = oDocLibraries
' Sometimes library not loaded as should ??
If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary)
Else
sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1)
bLocalStorage = False
Set oDocMacLib = oMacLibraries
End If
If oDocMacLib.IsLibraryLoaded(sLibrary) Then
Set oLibrary = oDocMacLib.getByName(sLibrary)
If oLibrary.hasElements() Then
vDialogs = oLibrary.getElementNames()
Select Case iMode
Case cstCount
iCount = iCount + UBound(vDialogs) + 1
Case cstByIndex, cstByName
For j = 0 To UBound(vDialogs)
If iMode = cstByIndex Then
If pvIndex = iCount Then bFound = True
iCount = iCount + 1
Else
If UCase(pvIndex) = UCase(vDialogs(j)) Then bFound = True
End If
If bFound Then
Set oLibDialog = oLibrary.getByName(vDialogs(j)) ' Create Dialog object
Exit For
End If
Next j
End Select
End If
End If
If bFound Then Exit For
Next i

If iMode = cstCount Then
Set vAllDialogs = New Collect
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
With vAllDialogs
._Name = vDialogs(j)
._Shortcut = "Dialogs!" & vDialogs(j)
Set ._Dialog = oLibDialog
._Library = sLibrary
._Storage = Iif(bLocalStorage, "DOCUMENT", "GLOBAL")
End With
End If

Exit_Function:
Set AllDialogs = vAllDialogs
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Not_Found:
TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex)
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set vDialogs = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Set vDialogs = Nothing
GoTo Exit_Function
End Function ' AllDialogs V0.9.5
Access2BaseDev Application AllForms Basic Forms (Procedure)
_CountOpenForms (Procedure)
OpenForm (Procedure)
Item (Procedure)
101
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._CheckArgument(pvIndex, 1, 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 iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object
iCurrentDoc = _A2B_.CurrentDocIndex()
If iCurrentDoc >= 0 Then
vCurrentDoc = _A2B_.CurrentDocument(iCurrentDoc)
Else
Goto Exit_Function
End If
If vCurrentDoc.DbConnect = DBCONNECTBASE Then Set oForms = vCurrentDoc.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 vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 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, vName As Variant, oDatabase As Object, bFound As Boolean
Select Case vCurrentDoc.DbConnect
Case DBCONNECTBASE
sAllForms() = oForms.getElementNames()
ofForm._DocEntry = 0
ofForm._DbEntry = 0
If iIndex= -1 Then ' String argument
vName = Utils._InList(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 DBCONNECTFORM
With vCurrentDoc
If iIndex = -1 Then
bFound = False
For i = 0 To UBound(vCurrentDoc.DbContainers)
Set oDatabase = vCurrentDoc.DbContainers(i).Database
If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then
bFound = True
ofForm._DbEntry = i
Exit For
End If
Next i
If Not bFound Then Goto Trace_Not_Found
ElseIf iIndex < 0 Or iIndex > UBound(vCurrentDoc.DbContainers) Then
Goto Trace_Error_Index
Else
ofForm._DbEntry = iIndex
Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database
End If
End With
vName = oDatabase.FormName
ofForm._DocEntry = iCurrentDoc
ofForm._Initialize(vName)
End Select

Set 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
Access2BaseDev Application AllModules Basic Item (Procedure) 142
REM -----------------------------------------------------------------------------------------------------------------------
Public Function AllModules(ByVal Optional pvIndex As Variant, ByVal Optional pbAllModules As Boolean) As Variant
' Return either a Collection or a Module object
' The modules are selected only if library is loaded
' (UNPUBLISHED) pbAllModules = False collects only the modules located in the currently open document

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "AllModules"
Utils._SetCalledSub(cstThisSub)

Dim iMode As Integer, vModules() As Variant, i As Integer, j As Integer, iCount As Integer
Dim oMacLibraries As Object, vAllModules As Variant, oLibrary As Object, vNames() As Variant, bFound As Boolean
Dim sScript As String, sLibrary As String, oDocLibraries As Object, sStorage As String
Dim vLibraries() As Variant, vMacLibraries() As Variant, vDocLibraries() As Variant, oDocMacLib As Object
Const cstCount = 0, cstByIndex = 1, cstByName = 2
Const cstDot = "."

If IsMissing(pvIndex) Then
iMode = cstCount
Else
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
If VarType(pvIndex) = vbString Then
iMode = cstByName
' Determine full name STORAGE.LIBRARY.MODULE
vNames = Split(pvIndex, cstDot)
If UBound(vNames) = 2 Then
ElseIf UBound(vNames) = 1 Then
pvIndex = MODDOCUMENT & cstDot & pvIndex
ElseIf UBound(vNames) = 0 Then
pvIndex = MODDOCUMENT & cstDot & "STANDARD" & cstDot & pvIndex
Else
GoTo Trace_Not_Found
End If
Else
iMode = cstByIndex
End If
End If

If IsMissing(pbAllModules) Then pbAllModules = True
If Not Utils._CheckArgument(pbAllModules, 2, vbBoolean) Then Goto Exit_Function

Set vAllModules = Nothing

Set oDocLibraries = _A2B_.CurrentDocument.Document.BasicLibraries ' ThisComponent.BasicLibraries
vDocLibraries = oDocLibraries.getElementNames()
If pbAllModules Then
Set oMacLibraries = GlobalScope.BasicLibraries
vMacLibraries = oMacLibraries.getElementNames()
'Remove Access2Base from the list
If _A2B_.ExcludeA2B Then
For i = 0 To UBound(vMacLibraries)
' If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
Next i
End If
vMacLibraries = Utils._TrimArray(vMacLibraries)
End If

If UBound(vDocLibraries) + UBound(vMacLibraries) < 0 Then ' No library
Set vAllModules = New Collect
vAllModules._CollType = COLLALLMODULES
vAllModules._ParentType = OBJAPPLICATION
vAllModules._ParentName = ""
vAllModules._Count = 0
Goto Exit_Function
End If

iCount = 0
For i = 0 To UBound(vDocLibraries) + UBound(vMacLibraries) + 1
bFound = False
If i <= UBound(vDocLibraries) Then
sLibrary = vDocLibraries(i)
sStorage = MODDOCUMENT
Set oDocMacLib = oDocLibraries
' Sometimes library not loaded as should ??
If Not oDocMacLib.IsLibraryLoaded(sLibrary) Then oDocMacLib.loadLibrary(sLibrary)
Else
sLibrary = vMacLibraries(i - UBound(vDocLibraries) - 1)
sStorage = MODGLOBAL
Set oDocMacLib = oMacLibraries
End If
If oDocMacLib.IsLibraryLoaded(sLibrary) Then
Set oLibrary = oDocMacLib.getByName(sLibrary)
If oLibrary.hasElements() Then
vModules = oLibrary.getElementNames()
Select Case iMode
Case cstCount
iCount = iCount + UBound(vModules) + 1
Case cstByIndex, cstByName
For j = 0 To UBound(vModules)
If iMode = cstByIndex Then
If pvIndex = iCount Then bFound = True
iCount = iCount + 1
Else
If UCase(pvIndex) = UCase(sStorage & cstDot & sLibrary & cstDot & vModules(j)) Then bFound = True
End If
If bFound Then
sScript = oLibrary.getByName(vModules(j)) ' Initiate Module object
iCount = i
Exit For
End If
Next j
End Select
End If
End If
If bFound Then Exit For
Next i

If iMode = cstCount Then
Set vAllModules = New Collect
vAllModules._CollType = COLLALLMODULES
vAllModules._ParentType = OBJAPPLICATION
vAllModules._ParentName = ""
vAllModules._Count = iCount
Else
If Not bFound Then
If iMode = cstByIndex Then Goto Trace_Error_Index Else Goto Trace_Not_Found
End If
Set vAllModules = New Module
vAllModules._Name = vModules(j)
vAllModules._LibraryName = sLibrary
Set vAllModules._Library = oLibrary
vAllModules._Storage = sStorage
vAllModules._Script = sScript
vAllModules._Initialize()
End If

Exit_Function:
Set AllModules = vAllModules
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Not_Found:
TraceError(TRACEFATAL, ERRMODULENOTFOUND, Utils._CalledSub(), 0, , pvIndex)
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set vModules = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Set vModules = Nothing
GoTo Exit_Function
End Function ' AllModules V1.7.0
Access2BaseDev Application CloseConnection Basic   18
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub CloseConnection ()

' Close all connections established by current document to free memory.
' - if Base document => close the one concerned database connection
' - if non-Base documents => close the connections of each individual standalone form

If IsEmpty(_A2B_) Then Goto Exit_Sub

Const cstThisSub = "CloseConnection"
Utils._SetCalledSub(cstThisSub)

Call _A2B_.CloseConnection()

Exit_Sub:
Utils._ResetCalledSub(cstThisSub)
Exit Sub
End Sub ' CloseConnection V1.2.0
Access2BaseDev Application CommandBars Basic Item (Procedure)
_PropertyGet (Procedure)
155
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CommandBars(Optional ByVal pvIndex As Variant, Optional ByRef poWindow As Object) As Variant
' Return an object of type CommandBar indicated by its index or its name (CASE-INSENSITIVE string)
' If no pvIndex argument, return a Collection type
' (Unpublished) With poWindow, force the frame in which toolbars are detected

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "CommandBars"
Utils._SetCalledSub(cstThisSub)

Dim iObjectsCount As Integer, sObjectName As String, oObject As Object
Dim oWindow As Object, iWindowType As Integer
Dim i As Integer, j As Integer, k As Integer, bFound As Boolean
Dim sSupportedModules() As Variant, vModules() As Variant, oModuleUI As Object
Dim oToolbar As Object, sToolbarName As String, vUIElements() As Variant, sToolbarFullName As String, iBuiltin As Integer

Const cstCustom = "CUSTOM"

Set oObject = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If

iObjectsCount = 0
bFound = False

If IsMissing(poWindow) Then Set oWindow = _SelectWindow() Else Set oWindow = poWindow
If IsNull(oWindow.Frame) Then Goto Trace_WindowError

' List of 21 modules
vModules = CreateUnoService("com.sun.star.frame.ModuleManager").getElementNames()

iWindowType = oWindow.WindowType
Select Case iWindowType ' Supported window types only
Case acForm
sSupportedModules = Array( "com.sun.star.sdb.FormDesign" )
Case acBasicIDE
sSupportedModules = Array( "com.sun.star.script.BasicIDE" )
Case acDatabaseWindow
sSupportedModules = Array( "com.sun.star.sdb.OfficeDatabaseDocument" )
Case acReport
sSupportedModules = Array( "com.sun.star.sdb.TextReportDesign" )
Case acDocument
Select Case oWindow.DocumentType
Case docCalc : sSupportedModules = Array( "com.sun.star.sheet.SpreadsheetDocument" )
Case docWriter : sSupportedModules = Array( "com.sun.star.text.TextDocument" )
Case docImpress : sSupportedModules = Array( "com.sun.star.presentation.PresentationDocument" )
Case docDraw : sSupportedModules = Array( "com.sun.star.drawing.DrawingDocument" )
Case docMath : sSupportedModules = Array( "com.sun.star.formula.FormulaProperties" )
Case Else : sSupportedModules = Array()
End Select
Case acTable, acQuery
sSupportedModules = Array( "com.sun.star.sdb.DataSourceBrowser" _
, "com.sun.star.sdb.TableDataView" _
)
Case acDiagram
sSupportedModules = Array( "com.sun.star.sdb.RelationDesign" )
Case acWelcome
sSupportedModules = Array( "com.sun.star.frame.StartModule" )
Case Else
sSupportedModules = Array()
End Select

' Find all standard and custom toolbars stored in LibO/AOO Base
Set oModuleUI = CreateUnoService("com.sun.star.ui.ModuleUIConfigurationManagerSupplier")
For k = 0 To UBound(vModules)
For j = 0 To UBound(sSupportedModules)
iBuiltin = 1 ' Default = builtin
If vModules(k) = sSupportedModules(j) Then ' Supported modules only
Set oToolbar = oModuleUI.getUIConfigurationManager(vModules(k))
vUIElements() = oToolbar.getUIElementsInfo(0)
For i = 0 To UBound(vUIElements)
sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL")
sToolbarName = Split(sToolbarFullName, "/")(2)
If _IsLeft(UCase(sToolbarName), UCase(cstCustom)) Then
sToolbarName = _GetPropertyValue(vUIElements(i), "UIName")
iBuiltin = 2
End If

iObjectsCount = iObjectsCount + 1
Select Case True
Case IsMissing(pvIndex)
Case VarType(pvIndex) = vbString
If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True
Case Else
If pvIndex < 0 Then Goto Trace_IndexError
If pvIndex = iObjectsCount - 1 Then bFound = True
End Select

If bFound Then
Set oObject = _NewCommandBar(vModules(k), sToolbarName, sToolbarFullName, iBuiltin)
Set oObject._Window = oWindow.Frame
Set oObject._Toolbar = oToolbar
Goto Exit_Function
End If
Next i
End If
Next j
Next k

' Find all (not builtin) toolbars stored in current document (typically forms)
iBuiltin = 3 ' Stored in form itself
Set oToolbar = oWindow.Frame.Controller.Model.getUIConfigurationManager
vUIElements() = oToolbar.getUIElementsInfo(0)
For i = 0 To UBound(vUIElements)
sToolbarFullName = _GetPropertyValue(vUIElements(i), "ResourceURL")
sToolbarName = _GetPropertyValue(vUIElements(i), "UIName")
iObjectsCount = iObjectsCount + 1
Select Case True
Case IsMissing(pvIndex)
Case VarType(pvIndex) = vbString
If UCase(pvIndex) = UCase(sToolbarName) Then bFound = True
Case Else
If pvIndex = iObjectsCount - 1 Then bFound = True
End Select
If bFound Then
Set oObject = _NewCommandBar("", sToolbarName, sToolbarFullName, iBuiltin)
Set oObject._Window = oWindow.Frame
Set oObject._Toolbar = oToolbar
Goto Exit_Function
End If
Next i

' MISSING : CUSTOM POPUPS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

Select Case True
Case IsMissing(pvIndex)
Set oObject = New Collect
oObject._CollType = COLLCOMMANDBARS
oObject._ParentType = OBJAPPLICATION
oObject._Count = iObjectsCount
Case VarType(pvIndex) = vbString
Goto Trace_NotFound
Case Else ' pvIndex is numeric
Goto Trace_IndexError
End Select

Exit_Function:
Set CommandBars = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("COMMANDBAR"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
Trace_WindowError:
TraceError(TRACEFATAL, ERRWINDOW, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' CommandBars V1,3,0
Access2BaseDev Application Controls Basic GetRows (Procedure) 43
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Controls(ByVal Optional pvObject As Variant, Optional ByVal pvIndex As Variant) As Variant
' Return an object of type Control indicated by either its index (integer) or its name (CASE-INSENSITIVE string)
' The 1st argument pvObject can be either
' an object of type FORM (1)
' a main form name as string
' an object of type SUBFORM (2)
' The Form property in the returned variant contains a SUBFORM type
' an object of type CONTROL and subtype GRIDCONTROL (3)
' an object of type OPTIONGROUP (4) 2nd argument, if any, must be numeric
' If no pvIndex argument, return a Collection type

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim vObject As Object
Const cstThisSub = "Controls"
Utils._SetCalledSub(cstThisSub)

If IsMissing(pvObject) Then Call _TraceArguments()
If IsNull(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
Controls = EMPTY

If VarType(pvObject) = vbString Then
Set vObject = Forms(pvObject)
If IsNull(vObject) Then Goto Exit_Function
Else
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM, OBJOPTIONGROUP, CTLGRIDCONTROL)) Then Goto Exit_Function
Set vObject = pvObject
End If

If IsMissing(pvIndex) Then
Controls = vObject.Controls()
Else
If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function
Controls = vObject.Controls(pvIndex)
End If

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEERROR, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' Controls V0.9.0
Access2BaseDev Application CurrentDb Basic _CurrentDb (Procedure)
TraceError (Procedure)
15
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDb() As Object
' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties

Const cstThisSub = "CurrentDb"
Utils._SetCalledSub(cstThisSub)

Set CurrentDb = Nothing
If IsEmpty(_A2B_) Then GoTo Exit_Function
Set CurrentDb = _A2B_.CurrentDb()

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' CurrentDb V1.1.0
Access2BaseDev Application CurrentUser Basic   15
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
Access2BaseDev Application DAvg Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DAvg( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return average of scope
Const cstThisSub = "DAvg"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DAvg
Access2BaseDev Application DCount Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DCount( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return # of occurrences of scope
Const cstThisSub = "DCount"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DCount
Access2BaseDev Application DLookup Basic   30
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DLookup( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
, ByVal Optional pvOrderClause As Variant _
) As Variant

' Return a value within a table
'Arguments: psExpr: an SQL expression
' psDomain: a table- or queryname
' pvCriteria: an optional WHERE clause
' pcOrderClause: an optional order clause incl. "DESC" if relevant
'Return: Value of the psExpr if found, else Null.
'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html
'Examples:
' 1. To find the last value, include DESC in the OrderClause, e.g.:
' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
' 2. To find the lowest non-null value of a field, use the Criteria, e.g.:
' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")

Const cstThisSub = "DLookup"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _
, Iif(IsMissing(pvCriteria), "", pvCriteria) _
, Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
)
Utils._ResetCalledSub(cstThisSub)
End Function ' DLookup
Access2BaseDev Application DMax Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DMax( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return maximum of scope
Const cstThisSub = "DMax"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DMax
Access2BaseDev Application DMin Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DMin( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return minimum of scope
Const cstThisSub = "DMin"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DMin
Access2BaseDev Application DStDev Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DStDev( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return standard deviation of scope
Const cstThisSub = "DStDev"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
Utils._ResetCalledSub(cstThisSub)
End Function ' DStDev
Access2BaseDev Application DStDevP Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DStDevP( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return standard deviation of scope
Const cstThisSub = "DStDevP"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
Utils._ResetCalledSub(cstThisSub)
End Function ' DStDevP
Access2BaseDev Application DSum Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DSum( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return sum of scope
Const cstThisSub = "DSum"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DSum
Access2BaseDev Application DVar Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DVar( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return variance of scope
Const cstThisSub = "DVar"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DVar
Access2BaseDev Application DVarP Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DVarP( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return variance of scope
Const cstThisSub = "DVarP"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DVarP
Access2BaseDev Application Events Basic   31
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Events(Optional poEvent As Variant) As Variant
' Return an event object corresponding with actual event

Dim vEvent As Variant
If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Events"
Utils._SetCalledSub(cstThisSub)

Set vEvent = Nothing
If IsMissing(poEvent) Then Goto Exit_Function
If IsNull(poEvent) Then Goto Exit_Function

If Not Utils._CheckArgument(poEvent, 1, vbObject, , False) Then Goto Exit_Function ' No error handling in CheckArgument
If Not Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error
Set vEvent = New Event
vEvent._Initialize(poEvent)

Exit_Function:
Set Events = vEvent
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEWARNING, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_Error:
' Errors are not displayed to avoid display infinite cycling
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent)))
Set vEvent = Nothing
Goto Exit_Function
End Function ' Events V0.9.1
Access2BaseDev Application Forms Basic Controls (Procedure)
FindRecord (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
OutputTo (Procedure)
_DatabaseForm (Procedure)
Item (Procedure)
getObject (Procedure)
62
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._AddNumeric(vbString)) Then Goto Exit_Function
End If

Select Case VarType(pvIndex)
Case vbString
Set ofForm = Application.AllForms(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, , Array(1, pvIndex))
Set vForms = Nothing
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set vForms = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' Forms V0.9.0
Access2BaseDev Application HtmlEncode Basic   33
REM -----------------------------------------------------------------------------------------------------------------------
Function HtmlEncode(ByVal pvString As Variant, ByVal Optional pvLength As Variant) As String
' Converts a string to an HTML-encoded string.

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "HtmlEncode"
Utils._SetCalledSub(cstThisSub)

HtmlEncode = ""

Dim sOutput As String, l As Long, lLength As Long
If IsMissing(pvLength) Then pvLength = 0
If Not Utils._CheckArgument(pvString, 1, vbString) Then Goto Exit_Function
If Not Utils._CheckArgument(pvLength, 1, _AddNumeric()) Then Goto Exit_Function

sOutput = ""
lLength = CLng(pvLength)
If Len(pvString) > 0 Then
For l = 1 To Len(pvString)
If lLength > 0 And Len(sOutput) > lLength Then Exit For
sOutput = sOutput & Utils._UTF8Encode(Mid(pvString, l, 1))
Next l
End If

HtmlEncode = sOutput

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' HtmlEncode V1.4.0
Access2BaseDev Application OpenConnection Basic   174
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenConnection ( _
Optional pvComponent As Variant _
, ByVal Optional pvUser As Variant _
, ByVal Optional pvPassword As Variant _
) As Object

' Establish connection with the database designated in the currently open front-end (.odb) document
' Call template:
' Call OpenConnection(ThisDatabaseDocument[, "", ""])
' Call stored in the OpenDocument event of the front-end database document
'OR
' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms
' Call template:
' Call OpenConnection(ThisComponent[, "", ""])
' Call stored in the OpenDocument event of the document
'
' User and Password arguments are obsolete (still tolerated)
' - because no mean has been found to connect protected db from .odb via API
' - because having multiple forms with multiple db's and multiple passwords is meaningless

Dim oComponent As Object, oForms As Object, iCurrent As Integer
Dim i As Integer, bFound As Boolean
Dim vCurrentDoc() As Variant
Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object
Dim sDatabaseURL As String, oHandler As Object
Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant
Dim sFormName As String

If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
Set OpenConnection = Nothing

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "OpenConnection"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvComponent) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function
Set oComponent = pvComponent
If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(1, oComponent))
Exit Function
End If
If IsMissing(pvUser) Then pvUser = ""
If IsMissing(pvPassword) Then pvPassword = ""
If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function

If Not IsArray(_A2B_.CurrentDoc) Then
vCurrentDoc() = Array()
Redim vCurrentDoc(0 To 0) ' Create at least one entry for database document
Else
vCurrentDoc() = _A2B_.CurrentDoc()
End If

' Find index of entry to use for new connection
With oComponent
Select Case .ImplementationName
Case "com.sun.star.comp.dba.ODatabaseDocument"
iCurrent = 0
Case Else ' "SwXTextDocument", "ScModelObj"
If UBound(vCurrentDoc) <= 0 Then ' First Calc or Writer during current session
iCurrent = 1
Else ' Search entry already used earlier by same component
bFound = False
For i = 1 To UBound(vCurrentDoc)
If Not IsEmpty(vCurrentDoc(i)) Then
If vCurrentDoc(i).Active And vCurrentDoc(i).URL = .URL Then
iCurrent = i
bFound = True
Exit For
End If
End If
Next i
End If
If Not bFound Then
iCurrent = UBound(vCurrentDoc) + 1 ' No entry found, increment array
ReDim Preserve vCurrentDoc(0 To iCurrent)
End If
End Select
End With

' Initialize future entry
Set vDocContainer = New DocContainer
Set vDocContainer.Document = oComponent
vDocContainer.Active = True
vDocContainer.URL = oComponent.URL
' Initialize each DbContainer entry
vDbContainers() = Array()
TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
Select Case oComponent.ImplementationName
Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments
vDbContainer = New DbContainer
vDbContainer.FormName = ""
Set vDbContainer.Database = New Database
Set vDbContainer.Database._This = vDbContainer.Database
With vDbContainer.Database
If Not oComponent.CurrentController.IsConnected Then
Set oHandler = createUnoService("com.sun.star.sdb.InteractionHandler")
Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler)
oComponent.CurrentController.connect()
Else
Set .Connection = oComponent.CurrentController.ActiveConnection
End If
vDocContainer.DbConnect = DBCONNECTBASE
._DbConnect = DBCONNECTBASE
Set .MetaData = .Connection.MetaData
._LoadMetadata()
If .MetaData.DatabaseProductName = "MySQL" Then
._ReadOnly = .MetaData.isReadOnly()
Else
._ReadOnly = .Connection.isReadOnly() ' Always True in Mysql ??
End If
Set .Document = oComponent
.Title = oComponent.Title
.URL = vDocContainer.URL
ReDim vDbContainers(0 To 0)
Set vDbContainers(0) = vDbContainer
TraceLog(TRACEANY, .Version, False)
TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False)
End With
Case Else
Set oForms = oComponent.CurrentController.Model.DrawPage.Forms
If oForms.Count < 1 Then Goto Error_MainForm
ReDim vDbContainers(0 To oForms.Count - 1)
For i = 0 To oForms.Count - 1
vDbContainer = New DbContainer ' To make distinct entries !!
sFormName = oForms.ElementNames(i)
Set vDbContainer.Database = New Database
Set vDbContainer.Database._This = vDbContainer.Database
With vDbContainer.Database
.FormName = sFormName
vDbContainer.FormName = sFormName
Set .Form = oForms.getByName(sFormName)
Set .Connection = .Form.ActiveConnection ' Might be Nothing in Windows at AOO/LO startup (not met in Linux)
If Not IsNull(.Connection) Then
Set .MetaData = .Connection.MetaData
._LoadMetadata()
._ReadOnly = .Connection.isReadOnly()
TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False)
End If
Set .Document = oComponent
.Title = oComponent.Title
.URL = .Form.DataSourceName
._DbConnect = DBCONNECTFORM
Set vDbContainers(i) = vDbContainer
vDbContainers(i).FormName = sFormName
TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False)
End With
Next i
vDocContainer.DbConnect = DBCONNECTFORM
End Select

vDocContainer.DbContainers() = vDbContainers()
Set vCurrentDoc(iCurrent) = vDocContainer

_A2B_.CurrentDoc = vCurrentDoc
Set OpenConnection = vDbContainers(0).Database


Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Set _A2B_.CurrentDoc = Array()
GoTo Exit_Function
Error_MainForm:
TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title)
Set _A2B_.CurrentDoc = Array()
GoTo Exit_Function
Trace_Error:
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
Goto Exit_Function
End Function ' OpenConnection V1.1.0
Access2BaseDev Application OpenDatabase Basic CopyObject (Procedure) 89
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenDatabase ( _
ByVal Optional pvDatabaseURL As Variant _
, ByVal Optional pvUser As Variant _
, ByVal Optional pvPassword As Variant _
, ByVal Optional pvReadOnly As Variant _
) As Object

' Return a database object based on input arguments:
' Call template:
' Call OpenDatabase("... databaseURL ..."[, "", "", True/False])
' pvDatabaseURL maby be the name of a registered database or the URL of the targeted .odb file
' Might be called from any AOO/LibO application, independently from OpenConnection

Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object
Dim i As Integer, bFound As Boolean
Dim sDatabaseURL As String

If IsEmpty(_A2B_) Then ' First use of Access2Base in current AOO/LibO session
Call Application._RootInit()
TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
End If
Set OpenDatabase = Nothing

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "OpenDatabase"
Utils._SetCalledSub(cstThisSub)
If pvDatabaseURL = "" Then Call _TraceArguments()
If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function
If IsMissing(pvUser) Then pvUser = ""
If IsMissing(pvPassword) Then pvPassword = ""
If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
If IsMissing(pvReadOnly) Then pvReadOnly = False
If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function

Set odbDatabase = New Database
Set odbDatabase._This = odbDatabase
odbDatabase._DbConnect = DBCONNECTANY

Set oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
sDbNames() = oBaseContext.getElementNames()
bFound = False
For i = 0 To UBound(sDbNames()) ' Enumerate registered databases and check non case-sensitive equality
If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then
sDatabaseURL = sDbNames(i)
Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
bFound = True
Exit For
End If
Next i
If Not bFound Then
sDatabaseURL = ConvertToURL(pvDatabaseURL)
If UCase(Right(sDatabaseURL, 4)) <> ".ODB" Then Goto Trace_Error
If Not FileExists(sDatabaseURL) Then Goto Trace_Error
Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
End If

Set odbDatabase.Connection = oBaseSource.getConnection(pvUser, pvPassword)
If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist
Set odbDatabase.MetaData = odbDatabase.Connection.MetaData
odbDatabase._LoadMetadata()
Else
Goto Trace_Error
End If

odbDatabase.URL = sDatabaseURL

If pvReadOnly Then
odbDatabase.Connection.isReadOnly = True
odbDatabase._ReadOnly = True
End If

Set OpenDatabase = odbDatabase

TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False)
TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False)


Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_Error:
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
Goto Exit_Function
End Function ' OpenDatabase V1.1.0
Access2BaseDev Application ProductCode Basic OpenConnection (Procedure)
OpenDatabase (Procedure)
5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProductCode()
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
ProductCode = "Access2Base " & _A2B_.VersionNumber
End Function ' ProductCode V0.9.1
Access2BaseDev Application SysCmd Basic CopyObject (Procedure) 91
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SysCmd(Optional pvAction As Variant _
, Optional pvText As Variant _
, Optional pvValue As Variant _
) As Variant
' Manage progress meter in the status bar
' Other values supported by MSAccess are ignored

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "SysCmd"
Utils._SetCalledSub(cstThisSub)
SysCmd = False

Const cstMissing = -1
Const cstBarLength = 350
If IsMissing(pvAction) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _
acSysCmdAccessDir _
, acSysCmdAccessVer _
, acSysCmdClearHelpTopic _
, acSysCmdClearStatus _
, acSysCmdGetObjectState _
, acSysCmdGetWorkgroupFile _
, acSysCmdIniFile _
, acSysCmdInitMeter _
, acSysCmdProfile _
, acSysCmdRemoveMeter _
, acSysCmdRuntime _
, acSysCmdSetStatus _
, acSysCmdUpdateMeter _
)) Then Goto Exit_Function
If IsMissing(pvValue) Then pvValue = cstMissing
If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function
Select Case pvAction
Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus
If IsMissing(pvText) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvText, 2, vbString) Then Goto Exit_Function
Case Else
End Select
If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function

Dim vBar As Variant, iLen As Integer
Set vBar = _A2B_.StatusBar
Select Case pvAction
Case acSysCmdAccessVer
SysCmd = Application.Version()
Goto Exit_Function
Case acSysCmdSetStatus
If pvValue <> cstMissing Then Goto Error_Arg
iLen = Len(pvText)
vBar = _NewBar()
If Not IsNull(vBar) Then vBar.start(Iif(iLen >= cstBarLength, pvText, pvText & Space(cstBarLength - iLen)), 0)
Case acSysCmdClearStatus
If pvValue <> cstMissing Then Goto Error_Arg
If Not IsNull(vBar) Then
vBar.end()
Set _A2B_.StatusBar = Nothing
End If
Case acSysCmdInitMeter
If pvValue = cstMissing Then Call _TraceArguments()
vBar = _NewBar()
If Not IsNull(vBar) Then vBar.start(pvText, pvValue)
Case acSysCmdUpdateMeter
If pvValue = cstMissing Then Call _TraceArguments()
If Not IsNull(vBar) Then ' Otherwise ignore !
vBar.setValue(pvValue)
If Len(pvText) > 0 Then vBar.setText(pvText)
End If
Case acSysCmdRemoveMeter
If Not IsNull(vBar) Then
vBar.end()
Set _A2B_.StatusBar = Nothing
End If
Case acSysCmdRuntime
SysCmd = False
Goto Exit_Function
Case Else
End Select

SysCmd = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_Arg:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(3, pvValue))
Goto Exit_Function
End Function ' SysCmd V0.9.1
Access2BaseDev Application TempVars Basic Item (Procedure)
getObject (Procedure)
Class_Initialize (Procedure)
53
REM -----------------------------------------------------------------------------------------------------------------------
Public Function TempVars(ByVal Optional pvIndex As Variant) As Variant
' Return either a Collection or a TempVar object

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "TempVars"
Utils._SetCalledSub(cstThisSub)

Dim iMode As Integer, vTempVars As Variant, bFound As Boolean
Const cstCount = 0
Const cstByIndex = 1
Const cstByName = 2

If IsMissing(pvIndex) Then
iMode = cstCount
Else
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex
End If

Set vTempVars = Nothing
Select Case iMode
Case cstCount ' Build Collection object
Set vTempVars = New Collect
With vTempVars
._CollType = COLLTEMPVARS
._Count = _A2B_.TempVars.Count
End With
Case cstByIndex ' Build TempVar object
If pvIndex < 0 Or pvIndex >= _A2B_.TempVars.Count Then Goto Trace_Error_Index
Set vTempVars = _A2B_.TempVars.Item(pvIndex + 1) ' Builtin collections start at 1
Case cstByName
bFound = _A2B_.hasItem(COLLTEMPVARS, pvIndex)
If Not bFound Then Goto Trace_NotFound
vTempVars = _A2B_.TempVars.Item(UCase(pvIndex))
End Select

Set TempVars = vTempVars

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set vTempVars = Nothing
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TEMPVAR"), pvIndex))
Goto Exit_Function
End Function ' TempVars V1.2.0
Access2BaseDev Application Version Basic SysCmd (Procedure) 4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Version() As String
Version = Utils._GetProductName()
End Function ' Version V0.9.1
Access2BaseDev Collect _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
6
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
_PropertiesList = Array("Count", "Item", "ObjectType")
End Function ' _PropertiesList
Access2BaseDev Collect _PropertyGet Basic Count (Procedure)
ObjectType (Procedure)
Properties (Procedure)
getProperty (Procedure)
30
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Collection.get" & psProperty)
_PropertyGet = Nothing

Select Case UCase(psProperty)
Case UCase("Count")
_PropertyGet = _Count
Case UCase("Item")
Case UCase("ObjectType")
_PropertyGet = _Type
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Collection.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Collection._PropertyGet", Erl)
_PropertyGet = Nothing
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Collect Add Basic   65
Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean
' Append a new TableDef or TempVar object to the TableDefs/TempVars collections

Const cstThisSub = "Collection.Add"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function

Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object
Dim vObject As Variant, oTempVar As Object
Add = False
If IsMissing(pvNew) Then Call _TraceArguments()

Select Case _CollType
Case COLLTABLEDEFS
If Not Utils._CheckArgument(pvNew, 1, vbObject) Then Goto Exit_Function
Set vObject = pvNew
With vObject
Set odbDatabase = ._ParentDatabase
If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
Set oConnection = odbDatabase.Connection
If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence
Set oTables = oConnection.getTables()
oTables.appendByDescriptor(.TableDescriptor)
Set .Table = oTables.getByName(._Name)
.CatalogName = .Table.CatalogName
.SchemaName = .Table.SchemaName
.TableName = .Table.Name
.TableDescriptor.dispose()
Set .TableDescriptor = Nothing
.TableFieldsCount = 0
.TableKeysCount = 0
End With
Case COLLTEMPVARS
If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function
If pvNew = "" Then Goto Error_Name
If IsMissing(pvValue) Then Call _TraceArguments()
If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name
Set oTempVar = New TempVar
oTempVar._Name = pvNew
oTempVar._Value = pvValue
_A2B_.TempVars.Add(oTempVar, UCase(pvNew))
Case Else
Goto Error_NotApplicable
End Select

_Count = _Count + 1
Add = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Sequence:
TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, vObject._Name)
Goto Exit_Function
Error_Name:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew))
AddItem = False
Goto Exit_Function
End Function ' Add V1.1.0
Access2BaseDev Collect Class_Initialize Basic Class_Terminate (Procedure) 11
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJCOLLECTION
_CollType = ""
_ParentType = ""
_ParentName = ""
Set _ParentDatabase = Nothing
_Count = 0
End Sub ' Constructor
Access2BaseDev Collect Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Collect Count Basic   3
Property Get Count() As Long
Count = _PropertyGet("Count")
End Property ' Count (get)
Access2BaseDev Collect Delete Basic   46
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Delete(ByVal Optional pvName As Variant) As Boolean
' Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections

Const cstThisSub = "Collection.Delete"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function

Dim odbDatabase As Object, oColl As Object, vName As Variant
Delete = False
If IsMissing(pvName) Then pvName = ""
If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
If pvName = "" Then Call _TraceArguments()

Select Case _CollType
Case COLLTABLEDEFS, COLLQUERYDEFS
If _A2B_.CurrentDocIndex() <> 0 Then Goto Error_NotApplicable
Set odbDatabase = Application._CurrentDb()
If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries()
With oColl
vName = _InList(pvName, .getElementNames(), True)
If vName = False Then Goto trace_NotFound
.dropByName(vName)
End With
odbDatabase.Document.store()
Case Else
Goto Error_NotApplicable
End Select

_Count = _Count - 1
Delete = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName))
Goto Exit_Function
End Function ' Delete V1.1.0
Access2BaseDev Collect Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Collect getProperty Basic   10
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
Access2BaseDev Collect hasProperty Basic   8
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
Access2BaseDev Collect Item Basic   101
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 Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error
Select Case _CollType
Case COLLCOMMANDBARCONTROLS ' Have no name
If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric()) Then Goto Exit_Function
Case Else
If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End Select

Dim vNames() As Variant, oProperty As Object

Set Item = Nothing
Select Case _CollType
Case COLLALLDIALOGS
Set Item = Application.AllDialogs(pvItem)
Case COLLALLFORMS
Set Item = Application.AllForms(pvItem)
Case COLLALLMODULES
Set Item = Application.AllModules(pvItem)
Case COLLCOMMANDBARS
Set Item = Application.CommandBars(pvItem)
Case COLLCOMMANDBARCONTROLS
Set Item = Application.CommandBars(_ParentName).CommandBarControls(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 = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem)
Case OBJRECORDSET
Set Item = _ParentDatabase.Recordsets(_ParentName).Fields(pvItem)
Case OBJTABLEDEF
Set Item = _ParentDatabase.TableDefs(_ParentName).Fields(pvItem)
End Select
Case COLLPROPERTIES
Select Case _ParentType
Case OBJCONTROL
Set Item = getObject(_ParentName).Properties(pvItem)
Case OBJSUBFORM
Set Item = getValue(_ParentName).Properties(pvItem)
Case OBJDATABASE
Set Item = _ParentDatabase.Properties(pvItem)
Case OBJDIALOG
Set Item = Application.AllDialogs(_ParentName).Properties(pvItem)
Case OBJFIELD
vNames() = Split(_ParentName, "/")
Select Case vNames(0)
Case OBJQUERYDEF
Set Item = _ParentDatabase.QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
Case OBJRECORDSET
Set Item = _ParentDatabase.Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem)
Case OBJTABLEDEF
Set Item = _ParentDatabase.TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
End Select
Case OBJFORM
Set Item = Application.Forms(_ParentName).Properties(pvItem)
Case OBJQUERYDEF
Set Item = _ParentDatabase.QueryDefs(_ParentName).Properties(pvItem)
Case OBJRECORDSET
Set Item = _ParentDatabase.Recordsets(_ParentName).Properties(pvItem)
Case OBJTABLEDEF
Set Item = _ParentDatabase.TableDefs(_ParentName).Properties(pvItem)
Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY
' NOT SUPPORTED
End Select
Case COLLQUERYDEFS
Set Item = _ParentDatabase.QueryDefs(pvItem)
Case COLLRECORDSETS
Set Item = _ParentDatabase.Recordsets(pvItem)
Case COLLTABLEDEFS
Set Item = _ParentDatabase.TableDefs(pvItem)
Case COLLTEMPVARS
Set Item = Application.TempVars(pvItem)
Case Else
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Property
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
Set Item = Nothing
GoTo Exit_Function
End Property ' V1.1.0
Access2BaseDev Collect ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Collect Properties Basic   20
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
Access2BaseDev Collect Remove Basic   39
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Remove(ByVal Optional pvName As Variant) As Boolean
' Remove a TempVar from the TempVars collection

Const cstThisSub = "Collection.Remove"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function

Dim oColl As Object, vName As Variant
Remove = False
If IsMissing(pvName) Then pvName = ""
If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
If pvName = "" Then Call _TraceArguments()

Select Case _CollType
Case COLLTEMPVARS
If Not _A2B_.hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name
_A2B_.TempVars.Remove(UCase(pvName))
Case Else
Goto Error_NotApplicable
End Select

_Count = _Count - 1
Remove = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Name:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName))
AddItem = False
Goto Exit_Function
End Function ' Remove V1.2.0
Access2BaseDev Collect RemoveAll Basic   26
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RemoveAll() As Boolean
' Remove the whole TempVars collection

Const cstThisSub = "Collection.Remove"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function

Select Case _CollType
Case COLLTEMPVARS
Set _A2B_.TempVars = New Collection
_Count = 0
Case Else
Goto Error_NotApplicable
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' RemoveAll V1.2.0
Access2BaseDev CommandBar _FindElement Basic CommandBarControls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
17
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FindElement(pvElements As Variant) As Integer
' Return -1 if not found, otherwise return index in elements table of LayoutManager

Dim i As Integer

_FindElement = -1
If Not IsArray(pvElements) Then Exit Function

For i = 0 To UBound(pvElements)
If _ResourceURL = pvElements(i).ResourceURL Then
_FindElement = i
Exit Function
End If
Next i

End Function
Access2BaseDev CommandBar _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
4
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
_PropertiesList = Array("BuiltIn", "Name", "ObjectType", "Visible")
End Function ' _PropertiesList
Access2BaseDev CommandBar _PropertyGet Basic BuiltIn (Procedure)
Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
Properties (Procedure)
Visible (Procedure)
getProperty (Procedure)
39
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "CommandBar.get" & psProperty
Utils._SetCalledSub(cstThisSub)
_PropertyGet = Nothing

Dim oLayout As Object, iElementIndex As Integer

Select Case UCase(psProperty)
Case UCase("BuiltIn")
_PropertyGet = ( _BarBuiltin = 1 )
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Visible")
Set oLayout = _Window.LayoutManager
iElementIndex = _FindElement(oLayout.getElements())
If iElementIndex < 0 Then _PropertyGet = False Else _PropertyGet = oLayout.isElementVisible(_ResourceURL)
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
_PropertyGet = Nothing
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev CommandBar _PropertySet Basic Visible (Procedure) 58
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
' Return True if property setting OK

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "CommandBar.set" & psProperty
Utils._SetCalledSub(cstThisSub)
_PropertySet = True
Dim iArgNr As Integer
Dim oLayout As Object, iElementIndex As Integer


Select Case UCase(_A2B_.CalledSub)
Case UCase("setProperty") : iArgNr = 3
Case UCase("CommandBar.setProperty") : iArgNr = 2
Case UCase(cstThisSub) : iArgNr = 1
End Select

If Not hasProperty(psProperty) Then Goto Trace_Error

Select Case UCase(psProperty)
Case UCase("Visible")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
Set oLayout = _Window.LayoutManager
With oLayout
iElementIndex = _FindElement(.getElements())
If iElementIndex < 0 Then
If pvValue Then
.createElement(_ResourceURL)
.showElement(_ResourceURL)
End If
Else
If pvValue <> .isElementVisible(_ResourceURL) Then
If pvValue Then .showElement(_ResourceURL) Else .hideElement(_ResourceURL)
End If
End If
End With
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev CommandBar BuiltIn Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get BuiltIn() As Boolean
BuiltIn = _PropertyGet("BuiltIn")
End Property ' BuiltIn (get)
Access2BaseDev CommandBar Class_Initialize Basic Class_Terminate (Procedure) 13
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJCOMMANDBAR
_Name = ""
_ResourceURL = ""
Set _Window = Nothing
_Module = ""
Set _Toolbar = Nothing
_BarBuiltin = 0
_BarType = -1
End Sub ' Constructor
Access2BaseDev CommandBar Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev CommandBar CommandBarControls Basic Controls (Procedure) 87
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CommandBarControls(Optional ByVal pvIndex As Variant) As Variant
' Return an object of type CommandBarControl indicated by its index
' Index is different from UNO index: separators do not count
' If no pvIndex argument, return a Collection type

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "CommandBar.CommandBarControls"
Utils._SetCalledSub(cstThisSub)

Dim oLayout As Object, vElements() As Variant, iIndexToolbar As Integer, oToolbar As Object
Dim i As Integer, iItemsCount As Integer, oSettings As Object, vItem() As Variant, bSeparator As Boolean
Dim oObject As Object

Set oObject = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function
If pvIndex < 0 Then Goto Trace_IndexError
End If

Select Case _BarType
Case msoBarTypeNormal, msoBarTypeMenuBar
Case Else : Goto Error_NotApplicable ' Status bar not supported
End Select

Set oLayout = _Window.LayoutManager
vElements = oLayout.getElements()
iIndexToolbar = _FindElement(vElements())
If iIndexToolbar < 0 Then Goto Error_NotApplicable ' Toolbar not visible
Set oToolbar = vElements(iIndexToolbar)

iItemsCount = 0
Set oSettings = oToolbar.getSettings(False)

bSeparator = False
For i = 0 To oSettings.getCount() - 1
Set vItem() = oSettings.getByIndex(i)
If _GetPropertyValue(vItem, "Type", 1) <> 1 Then ' Type = 1 indicates separator
iItemsCount = iItemsCount + 1
If Not IsMissing(pvIndex) Then
If pvIndex = iItemsCount - 1 Then
Set oObject = New CommandBarControl
With oObject
._ParentCommandBarName = _Name
._ParentCommandBar = oToolbar
._ParentBuiltin = ( _BarBuiltin = 1 )
._Element = vItem()
._InternalIndex = i
._Index = iItemsCount ' Indexes start at 1
._BeginGroup = bSeparator
End With
End If
bSeparator = False
End If
Else
bSeparator = True
End If
Next i

If IsNull(oObject) Then
Select Case True
Case IsMissing(pvIndex)
Set oObject = New Collect
oObject._CollType = COLLCOMMANDBARCONTROLS
oObject._ParentType = OBJCOMMANDBAR
oObject._ParentName = _Name
oObject._Count = iItemsCount
Case Else ' pvIndex is numeric
Goto Trace_IndexError
End Select
End If

Exit_Function:
Set CommandBarControls = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' CommandBarControls V1,3,0
Access2BaseDev CommandBar Controls Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
' Alias for CommandBarControls (VBA)

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "CommandBar.Controls"
Utils._SetCalledSub(cstThisSub)

Dim oObject As Object

If IsMissing(pvIndex) Then Set oObject = CommandBarControls() Else Set oObject = CommandBarControls(pvIndex)

Exit_Function:
Set Controls = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' Controls V1,3,0
Access2BaseDev CommandBar Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev CommandBar getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("CommandBar.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("CommandBar.getProperty")

End Function ' getProperty
Access2BaseDev CommandBar hasProperty Basic _PropertySet (Procedure) 8
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
Access2BaseDev CommandBar Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev CommandBar ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev CommandBar pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev CommandBar Properties Basic   20
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, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev CommandBar Reset Basic   19
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Reset() As Boolean
' Reset a whole command bar to its initial values

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "CommandBar.Reset"
Utils._SetCalledSub(cstThisSub)

_Toolbar.reload()

Exit_Function:
Reset = True
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Reset = False
GoTo Exit_Function
End Function ' Reset V1.3.0
Access2BaseDev CommandBar Visible Basic   7
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)
Access2BaseDev CommandBarControl _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
7
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
_PropertiesList = Array("BeginGroup", "BuiltIn", "Caption", "Index" _
, "ObjectType", "OnAction", "Parent" _
, "TooltipText", "Type", "Visible" _
)
End Function ' _PropertiesList
Access2BaseDev CommandBarControl _PropertyGet Basic BeginGroup (Procedure)
BuiltIn (Procedure)
Caption (Procedure)
Index (Procedure)
ObjectType (Procedure)
OnAction (Procedure)
Parent (Procedure)
Properties (Procedure)
TooltipText (Procedure)
pType (Procedure)
Visible (Procedure)
getProperty (Procedure)
53
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "CommandBarControl.get" & psProperty
Utils._SetCalledSub(cstThisSub)
_PropertyGet = Null

Dim oLayout As Object, iElementIndex As Integer
Dim sValue As String
Const cstUnoPrefix = ".uno:"

Select Case UCase(psProperty)
Case UCase("BeginGroup")
_PropertyGet = _BeginGroup
Case UCase("BuiltIn")
sValue = _GetPropertyValue(_Element, "CommandURL", "")
_PropertyGet = ( _IsLeft(sValue, cstUnoPrefix) )
Case UCase("Caption")
_PropertyGet = _GetPropertyValue(_Element, "Label", "")
Case UCase("Index")
_PropertyGet = _Index
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("OnAction")
_PropertyGet = _GetPropertyValue(_Element, "CommandURL", "")
Case UCase("Parent")
Set _PropertyGet = Application.CommandBars(_ParentCommandBarName)
Case UCase("TooltipText")
sValue = _GetPropertyValue(_Element, "Tooltip", "")
If sValue <> "" Then _PropertyGet = sValue Else _PropertyGet = _GetPropertyValue(_Element, "Label", "")
Case UCase("Type")
_PropertyGet = msoControlButton
Case UCase("Visible")
_PropertyGet = _GetPropertyValue(_Element, "IsVisible", "")
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
_PropertyGet = Nothing
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev CommandBarControl _PropertySet Basic Caption (Procedure)
OnAction (Procedure)
TooltipText (Procedure)
Visible (Procedure)
70
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
' Return True if property setting OK

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "CommandBarControl.set" & psProperty
Utils._SetCalledSub(cstThisSub)
_PropertySet = True
Dim iArgNr As Integer
Dim oSettings As Object, sValue As String


Select Case UCase(_A2B_.CalledSub)
Case UCase("setProperty") : iArgNr = 3
Case UCase("CommandBar.setProperty") : iArgNr = 2
Case UCase(cstThisSub) : iArgNr = 1
End Select

If Not hasProperty(psProperty) Then Goto Trace_Error
If _ParentBuiltin Then Goto Trace_Error ' Modifications of individual controls forbidden for builtin toolbars (design choice)

Const cstUnoPrefix = ".uno:"
Const cstScript = "vnd.sun.star.script:"

Set oSettings = _ParentCommandBar.getSettings(True)
Select Case UCase(psProperty)
Case UCase("OnAction")
If Not Utils._CheckArgument(pvValue, iArgNr, _AddNumeric(vbString), , False) Then Goto Trace_Error_Value
Select Case VarType(pvValue)
Case vbString
If _IsLeft(pvValue, cstUnoPrefix) Then
sValue = pvValue
ElseIf _IsLeft(pvValue, cstScript) Then
sValue = pvValue
Else
sValue = DoCmd.RunCommand(pvValue, True)
End If
Case Else ' Numeric
sValue = DoCmd.RunCommand(pvValue, True)
End Select
_SetPropertyValue(_Element, "CommandURL", sValue)
Case UCase("TooltipText")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
_SetPropertyValue(_Element, "Tooltip", pvValue)
Case UCase("Visible")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
_SetPropertyValue(_Element, "IsVisible", pvValue)
Case Else
Goto Trace_Error
End Select
oSettings.replaceByIndex(_InternalIndex, _Element)
_ParentCommandBar.setSettings(oSettings)

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev CommandBarControl BeginGroup Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get BeginGroup() As Boolean
BeginGroup = _PropertyGet("BeginGroup")
End Property ' BeginGroup (get)
Access2BaseDev CommandBarControl BuiltIn Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get BuiltIn() As Boolean
BuiltIn = _PropertyGet("BuiltIn")
End Property ' BuiltIn (get)
Access2BaseDev CommandBarControl Caption Basic   7
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)
Access2BaseDev CommandBarControl Class_Initialize Basic Class_Terminate (Procedure) 12
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJCOMMANDBARCONTROL
_Index = -1
_ParentCommandBarName = ""
Set _ParentCommandBar = Nothing
_ParentBuiltin = False
_Element = Array()
_BeginGroup = False
End Sub ' Constructor
Access2BaseDev CommandBarControl Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev CommandBarControl Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev CommandBarControl Execute Basic   30
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Execute()
' Execute the command stored in a toolbar button

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "CommandBarControl.Execute"
Utils._SetCalledSub(cstThisSub)

Dim sExecute As String

Execute = True
sExecute = _GetPropertyValue(_Element, "CommandURL", "")

Select Case True
Case sExecute = "" : Execute = False
Case _IsLeft(sExecute, ".uno:")
Execute = DoCmd.RunCommand(sExecute)
Case _IsLeft(sExecute, "vnd.sun.star.script:")
Execute = Utils._RunScript(sExecute, Array(Nothing))
Case Else
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Execute = False
GoTo Exit_Function
End Function ' Execute V1.3.0
Access2BaseDev CommandBarControl getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("CommandBarControl.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("CommandBar.getProperty")

End Function ' getProperty
Access2BaseDev CommandBarControl hasProperty Basic _PropertySet (Procedure) 8
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
Access2BaseDev CommandBarControl Index Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Index() As Integer
Index = _PropertyGet("Index")
End Property ' Index (get)
Access2BaseDev CommandBarControl ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev CommandBarControl OnAction Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnAction() As Variant
OnAction = _PropertyGet("OnAction")
End Property ' OnAction (get)

Property Let OnAction(ByVal pvValue As Variant)
Call _PropertySet("OnAction", pvValue)
End Property ' OnAction (set)
Access2BaseDev CommandBarControl Parent Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Parent() As Object
Parent = _PropertyGet("Parent")
End Property ' Parent (get)
Access2BaseDev CommandBarControl Properties Basic   20
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, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev CommandBarControl pType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function pType() As Integer
pType = _PropertyGet("Type")
End Function ' Type (get)
Access2BaseDev CommandBarControl TooltipText Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get TooltipText() As Variant
TooltipText = _PropertyGet("TooltipText")
End Property ' TooltipText (get)

Property Let TooltipText(ByVal pvValue As Variant)
Call _PropertySet("TooltipText", pvValue)
End Property ' TooltipText (set)
Access2BaseDev CommandBarControl Visible Basic   7
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)
Access2BaseDev Compatible DebugPrint Basic Dump (Procedure) 37
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub DebugPrint(ParamArray pvArgs() As Variant)

'Print arguments unconditionally in console
'Arguments are separated by a TAB (simulated by spaces)
'Some pvArgs might be missing: a TAB is still generated

Dim vVarTypes() As Variant, i As Integer
Const cstTab = 5
On Local Error Goto Exit_Sub ' Never interrupt processing
Utils._SetCalledSub("DebugPrint")
vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, vbArray + vbByte))

If UBound(pvArgs) >= 0 Then
For i = 0 To UBound(pvArgs)
If Not Utils._CheckArgument(pvArgs(i), i + 1, vVarTypes(), , False) Then pvArgs(i) = "[TYPE?]"
Next i
End If

Dim sOutput As String, sArg As String
sOutput = ""
For i = 0 To UBound(pvArgs)
sArg = Replace(Utils._CStr(pvArgs(i), _A2B_.DebugPrintShort), "\;", ";")
' Add argument to output
If i = 0 Then
sOutput = sArg
Else
sOutput = sOutput & Space(cstTab - (Len(sOutput) Mod cstTab)) & sArg
End If
Next i

TraceLog(TRACEANY, sOutput, False)

Exit_Sub:
Utils._ResetCalledSub("DebugPrint")
Exit Sub
End Sub ' DebugPrint V0.9.5
Access2BaseDev Control _Formats Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
37
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
Access2BaseDev Control _GetListener Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
34
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetListener(ByVal psProperty As String) As String
' Return the X...Listener corresponding with the property in argument

Select Case UCase(psProperty)
Case UCase("OnActionPerformed")
_GetListener = "XActionListener"
Case UCase("OnAdjustmentValueChanged")
_GetListener = "XAdjustmentListener"
Case UCase("OnApproveAction")
_GetListener = "XApproveActionListener"
Case UCase("OnApproveReset"), UCase("OnResetted")
_GetListener = "XResetListener"
Case UCase("OnApproveUpdate"), UCase("OnUpdated")
_GetListener = "XUpdateListener"
Case UCase("OnChanged")
_GetListener = "XChangeListener"
Case UCase("OnErrorOccurred")
_GetListener = "XErrorListener"
Case UCase("OnFocusGained"), UCase("OnFocusLost")
_GetListener = "XFocusListener"
Case UCase("OnItemStateChanged")
_GetListener = "XItemListener"
Case UCase("OnKeyPressed"), UCase("OnKeyReleased")
_GetListener = "XKeyListener"
Case UCase("OnMouseDragged"), UCase("OnMouseMoved")
_GetListener = "XMouseMotionListener"
Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased")
_GetListener = "XMouseListener"
Case UCase("OnTextChanged")
_GetListener = "XTextListener"
End Select

End Function ' _GetListener V1.7.0
Access2BaseDev Control _Initialize Basic   80
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize()
' Initialize new Control
' ControlModel, ParentType, Name, Shortcut, ControlView, ImplementationName, ClassId (if parent <> dialog)
' are presumed preexisting

' Identify SubType and ControlView
Dim sControlTypes() As Variant, i As Integer, vSplit() As Variant, sTrailer As String
sControlTypes = array( CTLCONTROL _
, CTLCOMMANDBUTTON _
, CTLRADIOBUTTON _
, CTLIMAGEBUTTON _
, CTLCHECKBOX _
, CTLLISTBOX _
, CTLCOMBOBOX _
, CTLGROUPBOX _
, CTLTEXTFIELD _
, CTLFIXEDTEXT _
, CTLGRIDCONTROL _
, CTLFILECONTROL _
, CTLHIDDENCONTROL _
, CTLIMAGECONTROL _
, CTLDATEFIELD _
, CTLTIMEFIELD _
, CTLNUMERICFIELD _
, CTLCURRENCYFIELD _
, CTLPATTERNFIELD _
, CTLSCROLLBAR _
, CTLSPINBUTTON _
, CTLNAVIGATIONBAR _
, CTLPROGRESSBAR _
, CTLFIXEDLINE _
)

Select Case _ParentType
Case CTLPARENTISDIALOG
vSplit = Split(ControlModel.getServiceName(), ".")
sTrailer = UCase(vSplit(UBound(vSplit)))
' Manage homonyms
Select Case sTrailer
Case "BUTTON" : sTrailer = CTLCOMMANDBUTTON
Case "EDIT" : sTrailer = CTLTEXTFIELD
Case Else
End Select
If sTrailer <> CTLFORMATTEDFIELD Then
For i = 0 To UBound(sControlTypes)
If sControlTypes(i) = sTrailer Then
_ClassId = i + 1
_SubType = sTrailer
_ControlType = _ClassId
Exit For
End If
Next i
Else
_ClassId = acFormattedField
_SubType = CTLFORMATTEDFIELD
_ControlType = _ClassId
End If
Case Else
'Is ClassId one of the properties ?
If _ClassId > 0 Then ' All control types have a ClassId except subforms
_SubType = sControlTypes(_ClassId - 1)
_ControlType = _ClassId
If _SubType = CTLTEXTFIELD Then ' Formatted fields belong to the TextField family
If _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper" _
Or _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper_ForcedFormatted" _
Or _ImplementationName = "com.sun.star.form.component.FormattedField" Then ' When in datagrid
_SubType = CTLFORMATTEDFIELD
_ControlType = acFormattedField
End If
End If
Else ' Initialize subform Control
If ControlModel.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then
_SubType = CTLSUBFORM
_ControlType = acSubform
End If
End If
End Select

End Sub ' _Initialize
Access2BaseDev Control _ListboxBound Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
35
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
Access2BaseDev Control _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
162
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
' Based on ControlProperties.ods analysis

Dim vFullPropertiesList() As Variant

'List established only once
If UBound(_ThisProperties) > -1 Then
_PropertiesList = _ThisProperties
Exit Function
End If

vFullPropertiesList = Array( _
"BackColor" _
, "BorderColor" _
, "BorderStyle" _
, "Cancel" _
, "Caption" _
, "ControlSource" _
, "ControlTipText" _
, "ControlType" _
, "Default" _
, "DefaultValue" _
, "Enabled" _
, "FontBold" _
, "FontItalic" _
, "FontName" _
, "FontSize" _
, "FontUnderline" _
, "FontWeight" _
, "ForeColor" _
, "Form" _
, "Format" _
, "ItemData" _
, "LinkChildFields" _
, "LinkMasterFields" _
, "ListCount" _
, "ListIndex" _
, "Locked" _
, "MultiSelect" _
, "Name" _
, "ObjectType" _
, "OnActionPerformed" _
, "OnAdjustmentValueChanged" _
, "OnApproveAction" _
, "OnApproveReset" _
, "OnApproveUpdate" _
, "OnChanged" _
, "OnErrorOccurred" _
, "OnFocusGained" _
, "OnFocusLost" _
, "OnItemStateChanged" _
, "OnKeyPressed" _
, "OnKeyReleased" _
, "OnMouseDragged" _
, "OnMouseEntered" _
, "OnMouseExited" _
, "OnMouseMoved" _
, "OnMousePressed" _
, "OnMouseReleased" _
, "OnResetted" _
, "OnTextChanged" _
, "OnUpdated" _
, "OptionValue" _
, "Page" _
, "Parent" _
, "Picture" _
, "Required" _
, "RowSource" _
, "RowSourceType" _
, "Selected" _
, "SelLength" _
, "SelStart" _
, "Seltext" _
, "SpecialEffect" _
, "SubType" _
, "TabIndex" _
, "TabStop" _
, "Tag" _
, "Text" _
, "TextAlign" _
, "TripleState" _
, "Value" _
, "Visible" _
)
Dim vPropertiesMatrix(25) As Variant
Select Case _ParentType
Case CTLPARENTISFORM, CTLPARENTISSUBFORM
vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,63,64,65,67,68,69,70)
vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,41,42,43,44,45,46,47,52,53,62,63,64,65,67,69,70)
vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70)
vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,48,52,62,63,64,65,66,69,70)
vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,65,67,70)
vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,70)
vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,62,65,70)
vPropertiesMatrix(acHiddenControl) = Array(7,27,28,52,62,65,69,70)
vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,36,37,39,40,41,42,43,44,45,46,52,53,62,63,64,65,70)
vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,53,54,62,63,64,65,70)
vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,63,64,65,67,69,70)
vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,63,64,65,70)
vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70)
vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70)
vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70)
vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70)
vPropertiesMatrix(0) = Array(7,18,21,22,27,28,52,62)
vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70)
Case CTLPARENTISGROUP
' To be duplicated from above !!!
vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70)
Case CTLPARENTISGRID
vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,65,67,68,69)
vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,65,66,67,69)
vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69)
vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69)
vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69)
vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,65,67,69)
vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69)
vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69)
vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69)
vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69)
Case CTLPARENTISDIALOG
vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,61,62,63,64,65,67,68,69,70)
vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,36,37,38,39,40,41,42,43,44,45,46,48,51,52,55,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,67,70)
vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70)
vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70)
vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,67,70)
vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70)
vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,70)
vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,55,57,62,63,64,65,67,69,70)
vPropertiesMatrix(acNavigationBar) = Array(36,37,39,40,41,42,43,44,45,46)
vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70)
vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,69,70)
vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,50,51,52,61,62,63,64,65,67,69,70)
vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,69,70)
vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70)
vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70)
End Select

Dim i As Integer, iIndex As Integer
If _ControlType = acSubForm Then iIndex = 0 Else iIndex = _ControlType
If IsEmpty(vPropertiesMatrix(iIndex)) Then
_ThisProperties = Array()
Else
ReDim _ThisProperties(0 To UBound(vPropertiesMatrix(iIndex)))
For i = 0 To UBound(_ThisProperties)
_ThisProperties(i) = vFullPropertiesList(vPropertiesMatrix(iIndex)(i))
Next i
End If

_PropertiesList = _ThisProperties()

End Function ' _PropertiesList
Access2BaseDev Control _PropertyGet Basic BackColor (Procedure)
BorderColor (Procedure)
BorderStyle (Procedure)
Cancel (Procedure)
Caption (Procedure)
ControlSource (Procedure)
ControlTipText (Procedure)
ControlType (Procedure)
Default (Procedure)
DefaultValue (Procedure)
Enabled (Procedure)
FontBold (Procedure)
FontItalic (Procedure)
FontName (Procedure)
FontSize (Procedure)
FontUnderline (Procedure)
FontWeight (Procedure)
ForeColor (Procedure)
Form (Procedure)
Format (Procedure)
ItemData (Procedure)
ListCount (Procedure)
ListIndex (Procedure)
Locked (Procedure)
MultiSelect (Procedure)
Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
OnActionPerformed (Procedure)
OnAdjustmentValueChanged (Procedure)
OnApproveAction (Procedure)
OnApproveReset (Procedure)
OnApproveUpdate (Procedure)
OnChanged (Procedure)
OnErrorOccurred (Procedure)
OnFocusGained (Procedure)
OnFocusLost (Procedure)
OnItemStateChanged (Procedure)
OnKeyPressed (Procedure)
OnKeyReleased (Procedure)
OnMouseDragged (Procedure)
OnMouseEntered (Procedure)
OnMouseExited (Procedure)
OnMouseMoved (Procedure)
OnMousePressed (Procedure)
OnMouseReleased (Procedure)
OnResetted (Procedure)
OnTextChanged (Procedure)
OnUpdated (Procedure)
OptionValue (Procedure)
Page (Procedure)
Parent (Procedure)
Picture (Procedure)
Properties (Procedure)
Required (Procedure)
RowSource (Procedure)
RowSourceType (Procedure)
Selected (Procedure)
SelLength (Procedure)
SelStart (Procedure)
SelText (Procedure)
SpecialEffect (Procedure)
SubType (Procedure)
TabIndex (Procedure)
TabStop (Procedure)
Tag (Procedure)
Text (Procedure)
pText (Procedure)
TextAlign (Procedure)
TripleState (Procedure)
Value (Procedure)
Visible (Procedure)
getProperty (Procedure)
485
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant
' Return property value of the psProperty property name

Dim iArg As Integer
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Control.get" & psProperty)
_PropertyGet = EMPTY

'Check Index argument
Dim iArgNr As Integer
If Not IsMissing(pvIndex) Then
Select Case UCase(_A2B_.CalledSub)
Case UCase("getProperty") : iArgNr = 3
Case UCase("Control.getProperty") : iArgNr = 2
Case UCase("Control.get" & psProperty) : iArgNr = 1
End Select
If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
End If

Dim vDefaultValue As Variant, oDefaultValue As Object, vValue As Variant, oValue As Object, iIndex As Integer
Dim lListIndex As Long, i As Integer, j As Integer, vCurrentValue As Variant, lListCount As Long
Dim vListboxValue As Variant, vListSource, bSelected() As Boolean, bListboxBound As Boolean
Dim vGet As Variant, vDate As Variant
Dim ofSubForm As Object
Dim vFormats() As Variant
Dim vSelection As Variant, sSelectedText As String
Dim oControlEvents As Object, sEventName As String

If Not hasProperty(psProperty) Then Goto Trace_Error

Select Case UCase(psProperty)
Case UCase("BackColor")
If Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then _PropertyGet = ControlModel.BackgroundColor
Case UCase("BorderColor")
If Utils._hasUNOProperty(ControlModel, "BorderColor") Then _PropertyGet = ControlModel.BorderColor
Case UCase("BorderStyle")
If Utils._hasUNOProperty(ControlModel, "Border") Then _PropertyGet = ControlModel.Border
Case UCase("Cancel")
If Utils._hasUNOProperty(ControlModel, "PushButtonType") Then _PropertyGet = ( ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL )
Case UCase("Caption")
If Utils._hasUNOProperty(ControlModel, "Label") Then _PropertyGet = ControlModel.Label
Case UCase("ControlSource")
If Utils._hasUNOProperty(ControlModel, "DataField") Then _PropertyGet = ControlModel.DataField
Case UCase("ControlTipText")
If Utils._hasUNOProperty(ControlModel, "HelpText") Then _PropertyGet = ControlModel.HelpText
Case UCase("ControlType")
_PropertyGet = _ControlType
Case UCase("Default")
If Utils._hasUNOProperty(ControlModel, "DefaultButton") Then _PropertyGet = ControlModel.DefaultButton
Case UCase("DefaultValue")
Select Case _SubType
Case CTLCHECKBOX, CTLRADIOBUTTON
If Utils._hasUNOProperty(ControlModel, "DefaultState") Then _PropertyGet = ControlModel.DefaultState
Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD
If Utils._hasUNOProperty(ControlModel, "DefaultText") Then _PropertyGet = ControlModel.DefaultText
Case CTLCURRENCYFIELD, CTLNUMERICFIELD
If Utils._hasUNOProperty(ControlModel, "DefaultValue") Then _PropertyGet = ControlModel.DefaultValue
Case CTLDATEFIELD
If Utils._hasUNOProperty(ControlModel, "DefaultDate") Then
Select Case VarType(ControlModel.DefaultDate)
Case vbLong ' AOO and LO <= 4.1
vDefaultValue = ControlModel.DefaultDate
vGet = DateSerial(Left(vDefaultValue, 4), Mid(vDefaultValue, 5, 2), Right(vDefaultValue, 2))
Case vbObject ' LO >= 4.2 com.sun.star.Util.Date
Set oDefaultValue = ControlModel.DefaultDate
vGet = DateSerial(oDefaultValue.Year,oDefaultValue.Month, oDefaultValue.Day)
Case vbEmpty
End Select
End If
Case CTLFORMATTEDFIELD
If Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then _PropertyGet = ControlModel.EffectiveDefault
Case CTLLISTBOX
If Utils._hasUNOProperty(ControlModel, "DefaultSelection") And Utils._hasUNOProperty(ControlModel, "StringItemList") Then
vDefaultValue = ControlModel.DefaultSelection
If IsArray(vDefaultValue) Then
If UBound(vDefaultValue) >= LBound(vDefaultValue) Then ' Is array initialized ?
iIndex = UBound(ControlModel.StringItemList)
If vDefaultValue(0) >= 0 And vDefaultValue(0) <= iIndex Then _PropertyGet = ControlModel.StringItemList(vDefaultValue(0))
' Only first default value is considered
End If
End If
End If
Case CTLSPINBUTTON
If Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then _PropertyGet = ControlModel.DefaultSpinValue
Case CTLTIMEFIELD
If Utils._hasUNOProperty(ControlModel, "DefaultTime") Then
Select Case VarType(ControlModel.DefaultTime)
Case vbLong ' AOO and LO <= 4.1
_PropertyGet = ControlModel.DefaultTime
Case vbObject ' LO >= 4.2 com.sun.star.Util.Time
Set oDefaultValue = ControlModel.DefaultTime
_PropertyGet = TimeSerial(oDefaultValue.Hours, oDefaultValue.Minutes, oDefaultValue.Seconds)
Case vbEmpty
End Select
End If
Case Else
Goto Trace_Error
End Select
Case UCase("Enabled")
If Utils._hasUNOProperty(ControlModel, "Enabled") Then _PropertyGet = ControlModel.Enabled
Case UCase("FontBold")
If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ( ControlModel.FontWeight >= com.sun.star.awt.FontWeight.BOLD )
Case UCase("FontItalic")
If Utils._hasUNOProperty(ControlModel, "FontSlant") Then _PropertyGet = ( ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC )
Case UCase("FontName")
If Utils._hasUNOProperty(ControlModel, "FontName") Then _PropertyGet = ControlModel.FontName
Case UCase("FontSize")
If Utils._hasUNOProperty(ControlModel, "FontHeight") Then _PropertyGet = ControlModel.FontHeight
Case UCase("FontUnderline")
If Utils._hasUNOProperty(ControlModel, "FontUnderline") Then _PropertyGet = _
Not ( ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE _
Or ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.DONTKNOW )
Case UCase("FontWeight")
If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ControlModel.FontWeight
Case UCase("ForeColor")
If Utils._hasUNOProperty(ControlModel, "TextColor") Then _PropertyGet = ControlModel.TextColor
Case UCase("Form")
Set ofSubForm = New SubForm ' Start building the SUBFORM object
With ofSubForm
Set .DatabaseForm = ControlModel
._Name = _Name
._Shortcut = _Shortcut & ".Form"
._MainForm = _MainForm
.ParentComponent = _FormComponent
._DocEntry = _DocEntry
._DbEntry = _DbEntry
._OrderBy = ControlModel.Order
End With
set _PropertyGet = ofSubForm
Case UCase("Format")
vFormats = _Formats(_Subtype)
Select Case _SubType
Case CTLDATEFIELD
If Utils._hasUNOProperty(ControlModel, "DateFormat") Then
If ControlModel.DateFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.DateFormat)
End If
Case CTLTIMEFIELD
If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then
If ControlModel.TimeFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.TimeFormat)
End If
Case Else
If Utils._hasUNOProperty(ControlModel, "FormatKey") Then
If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then
_PropertyGet = ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString
End If
End If
End Select
Case UCase("ItemData")
If Utils._hasUNOProperty(ControlModel, "StringItemList") Then
If IsMissing(pvIndex) Then
_PropertyGet = ControlModel.StringItemList
Else
If pvIndex < 0 Or pvIndex > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Index
_PropertyGet = ControlModel.StringItemList(pvIndex)
End If
End If
Case UCase("ListCount")
If Utils._hasUNOProperty(ControlModel, "StringItemList") Then _PropertyGet = UBound(ControlModel.StringItemList) + 1
Case UCase("ListIndex")
If Utils._hasUNOProperty(ControlModel, "StringItemList") Then
lListIndex = -1 ' Either Multiple selections or no selection at all
Select Case _SubType
Case CTLCOMBOBOX
If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error
iIndex = 0
If ControlModel.Text <> "" Then
For j = 0 To UBound(ControlModel.StringItemList)
If ControlModel.StringItemList(j) = ControlModel.Text Then
lListIndex = j
iIndex = iIndex + 1
End If
Next j
If iIndex <> 1 Then lListIndex = -1 ' Multiselection or synonyms rejected
End If
Case CTLLISTBOX ' No mean found to access bound column !! See mail Lionel 10/5/2013 for improvement
If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error
If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected
Else ' Mono selection
If _ParentType <> CTLPARENTISDIALOG Then ' getCurrentValue not found in dialog listboxes ??
vCurrentValue = ControlModel.getCurrentValue() ' Space or uninitialized array if no selection at all
If IsArray(vCurrentValue) Then ' Is an array if MultiSelect
vListboxValue = ""
If UBound(vCurrentValue) = 0 Then vListboxValue = vCurrentValue(0)
Else
vListboxValue = vCurrentValue
End If
If vListboxValue <> "" Then ' Speed up search PM Pastim 12/02/2013
If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0)
End If
Else
If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0)
End If
End If
End Select
_PropertyGet = lListIndex
End If
Case UCase("Locked")
If Utils._hasUNOProperty(ControlModel, "ReadOnly") Then _PropertyGet = ControlModel.ReadOnly
Case UCase("MultiSelect")
If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then
_PropertyGet = ControlModel.MultiSelection ' Boolean in OO, Integer (0, 1 or 2) in VBA
ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: only for GridControls !? Changed in OO >= 3,3 !?
_PropertyGet = ControlModel.MultiSelectionSimpleMode
Else
_PropertyGet = False
End If
Case UCase("Name")
_PropertyGet = _Name
Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _
, UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _
, UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
, UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
, UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _
, UCase("OnUpdated")
Select Case _ParentType
Case CTLPARENTISDIALOG
Set oControlEvents = ControlModel.getEvents()
sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty)
If oControlEvents.hasByName(sEventName) Then
_PropertyGet = oControlEvents.getByName(sEventName).ScriptCode
Else
_PropertyGet = ""
End If
Case Else
_PropertyGet = Utils._GetEventScriptCode(ControlModel, psProperty, _Name)
End Select
Case UCase("OptionValue")
If Utils._hasUNOProperty(ControlModel, "RefValue") Then
If ControlModel.RefValue <> "" Then
_PropertyGet = ControlModel.RefValue
ElseIf Utils._hasUNOProperty(ControlModel, "Label") Then
_PropertyGet = ControlModel.Label
End If
End If
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Page")
If Utils._hasUNOProperty(ControlModel, "Step") Then _PropertyGet = ControlModel.Step
Case UCase("Parent")
Set _PropertyGet = PropertiesGet._ParentObject(_Shortcut)
Case UCase("Picture")
_PropertyGet = ConvertToUrl(ControlModel.ImageURL)
Case UCase("Required")
If Utils._hasUNOProperty(ControlModel, "InputRequired") Then _PropertyGet = ControlModel.InputRequired
Case UCase("RowSource")
Select Case _ParentType
Case CTLPARENTISDIALOG
If Utils._hasUNOProperty(ControlModel, "StringItemList") Then
If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList)
_PropertyGet = Join(vListSource, ";")
End If
Case Else
If Utils._hasUNOProperty(ControlModel, "ListSource") Then
Select Case ControlModel.ListSourceType
Case com.sun.star.form.ListSourceType.VALUELIST _
, com.sun.star.form.ListSourceType.TABLEFIELDS
If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList)
Case com.sun.star.form.ListSourceType.TABLE _
, com.sun.star.form.ListSourceType.QUERY _
, com.sun.star.form.ListSourceType.SQL _
, com.sun.star.form.ListSourceType.SQLPASSTHROUGH
If IsArray(ControlModel.ListSource) Then vListSource = ControlModel.ListSource Else vListSource = Array(ControlModel.ListSource)
End Select
_PropertyGet = Join(vListSource, ";")
End If
End Select
Case UCase("RowSourceType")
If Utils._hasUNOProperty(ControlModel, "ListSourceType") Then _PropertyGet = ControlModel.ListSourceType
Case UCase("Selected")
If Utils._hasUNOProperty(ControlModel, "StringItemList") Then
lListIndex = UBound(ControlModel.StringItemList)
If Not IsMissing(pvIndex) Then
If pvIndex < 0 Or pvIndex > lListIndex Then Goto Trace_Error_Index
End If
If lListIndex < 0 Then ' Do nothing if listbox empty
_PropertyGet = Array()
Else
Redim bSelected(0 To lListIndex)
For j = 0 To lListIndex
bSelected(j) = False
Next j
For j = 0 To UBound(ControlModel.SelectedItems)
iIndex = ControlModel.SelectedItems(j)
If iIndex >= 0 And iIndex <= lListIndex Then bSelected(iIndex) = True
Next j
If IsMissing(pvIndex) Then _PropertyGet = bSelected Else _PropertyGet = bSelected(pvIndex)
End If
End If
Case UCase("SelLength")
If Utils._hasUNOProperty(ControlView, "Selection") Then
vSelection = ControlView.getSelection()
If vSelection.Max >= vSelection.Min Then
_PropertyGet = vSelection.Max - vSelection.Min
Else
_PropertyGet = 0 ' probably control does not have focus
End If
Else
_PropertyGet = 0
End If
Case UCase("SelStart")
If Utils._hasUNOProperty(ControlView, "Selection") Then
vSelection = ControlView.getSelection()
If vSelection.Max >= vSelection.Min Then
_PropertyGet = vSelection.Min + 1
Else
_PropertyGet = 1 ' probably control does not have focus
End If
Else
_PropertyGet = 1
End If
Case UCase("SelText")
If Utils._hasUNOProperty(ControlView, "SelectedText") Then
_PropertyGet = ControlView.getSelectedText()
Else
_PropertyGet = ""
End If
Case UCase("SpecialEffect")
If Utils._hasUNOProperty(ControlModel, "VisualEffect") Then _PropertyGet = ControlModel.VisualEffect
Case UCase("SubType")
_PropertyGet = _SubType
Case UCase("TabIndex")
If Utils._hasUNOProperty(ControlModel, "TabIndex") Then _PropertyGet = ControlModel.TabIndex
Case UCase("TabStop")
If Utils._hasUNOProperty(ControlModel, "TabStop") Then _PropertyGet = ControlModel.TabStop
Case UCase("Tag")
If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag
Case UCase("Text")
Select Case _SubType
Case CTLDATEFIELD
If Utils._hasUNOProperty(ControlModel, "Date") Then
If Utils._hasUNOProperty(ControlModel, "FormatKey") Then
If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then
Select Case VarType(ControlModel.Date)
Case vbLong ' AOO and LO <= 4.1
vDate = DateSerial(Left(ControlModel.Date, 4), Mid(ControlModel.Date, 5, 2), Right(ControlModel.Date, 2))
Case vbObject ' LO >= 4.2
vDate = DateSerial(ControlModel.Date.Year, ControlModel.Date.Month, ControlModel.Date.Day)
Case vbEmpty
End Select
_PropertyGet = Format(vDate, ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString)
End If
End If
End If
Case CTLTIMEFIELD
If Utils._hasUNOProperty(ControlModel, "Text") Then
Select Case VarType(ControlModel.Time)
Case vbLong ' AOO and LO <= 4.1
_PropertyGet = Format(ControlModel.Time, "HH:MM:SS")
Case vbObject ' LO >= 4.2 com.sun.star.Util.Time
Set oValue = ControlModel.Time
_PropertyGet = Format(TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds), "HH:MM:SS")
Case vbEmpty
End Select
End If
Case Else
If Utils._hasUNOProperty(ControlModel, "Text") Then _PropertyGet = ControlModel.Text
End Select
Case UCase("TextAlign")
If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag
Case UCase("TripleState")
If Utils._hasUNOProperty(ControlModel, "TriState") Then _PropertyGet = ControlModel.TriState
Case UCase("Value")
Select Case _SubType
Case CTLCHECKBOX
If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ControlModel.State
Case CTLCOMMANDBUTTON
vGet = False
If Utils._hasUNOProperty(ControlModel, "Toggle") Then
If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ( ControlModel.State = 1 )
End If
Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD
If Utils._hasUNOProperty(ControlModel, "Text") Then vGet = ControlModel.Text
Case CTLCURRENCYFIELD
If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value
Case CTLDATEFIELD
If Utils._hasUNOProperty(ControlModel, "Date") Then
Select Case VarType(ControlModel.Date)
Case vbLong ' AOO and LO <= 4.1
vValue = ControlModel.Date
vGet = DateSerial(Left(vValue, 4), Mid(vValue, 5, 2), Right(vValue, 2))
Case vbObject ' LO >= 4.2 com.sun.star.Util.Date
Set oValue = ControlModel.Date
vGet = DateSerial(oValue.Year, oValue.Month, oValue.Day)
Case vbEmpty
End Select
End If
Case CTLFORMATTEDFIELD
If Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then vGet = ControlModel.EffectiveValue
Case CTLHIDDENCONTROL
If Utils._hasUNOProperty(ControlModel, "HiddenValue") Then vGet = ControlModel.HiddenValue
Case CTLLISTBOX
If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error
If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error
If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected
vGet = EMPTY ' Listbox has no value, only an array of Selected flags to identify values
Else ' Mono selection
Select Case _ParentType
Case CTLPARENTISDIALOG
If Ubound(ControlModel.SelectedItems) >= 0 Then
lListIndex = Controlmodel.Selecteditems(0)
If lListIndex > -1 And lListIndex <= UBound(ControlModel.StringItemList) Then
vGet = ControlModel.StringItemList(lListIndex)
Else
vGet = EMPTY
End If
End If
Case Else
vCurrentValue = ControlModel.getCurrentValue() ' Space or uninitialized array if no selection at all
If IsArray(vCurrentValue) Then ' Is an array if MultiSelect
If UBound(vCurrentValue) >= LBound(vCurrentValue) Then
vListboxValue = vCurrentValue(0)
Else
vListboxValue = ""
End If
Else
vListboxValue = vCurrentValue
End If
lListIndex = -1 ' Speed up getting value PM PASTIM 12/02/2013
If vListboxValue <> "" Then
If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0)
End If
' If listbox has hidden column = real bound field, then explore ValueItemList
bListboxBound = _ListboxBound()
If bListboxBound Then
If lListIndex > -1 Then vGet = ControlModel.ValueItemList(lListIndex) ' PASTIM
Else
vGet = vListboxValue
End If
End Select
End If
Case CTLNUMERICFIELD
If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value
Case CTLPROGRESSBAR
If Utils._hasUNOProperty(ControlModel, "ProgressValue") Then vGet = ControlModel.ProgressValue
Case CTLSCROLLBAR
If Utils._hasUNOProperty(ControlModel, "ScrollValue") Then vGet = ControlModel.ScrollValue
Case CTLSPINBUTTON
If Utils._hasUNOProperty(ControlModel, "SpinValue") Then vGet = ControlModel.SpinValue
Case CTLTIMEFIELD
If Utils._hasUNOProperty(ControlModel, "Time") Then
Select Case VarType(ControlModel.Time)
Case vbLong ' AOO and LO <= 4.1
vGet = ControlModel.Time
Case vbObject ' LO >= 4.2 com.sun.star.Util.Time
Set oValue = ControlModel.Time
vGet = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)
Case vbEmpty
End Select
End If
Case Else
End Select
If _SubType <> CTLLISTBOX Then ' Give getCurrentValue an additional try
If IsEmpty(vGet) And Utils._hasUNOMethod(ControlModel, "getCurrentValue") Then vGet = ControlModel.getCurrentValue()
End If
_PropertyGet = vGet
Case UCase("Visible")
Select Case _SubType
Case CTLHIDDENCONTROL
_PropertyGet = False
Case Else
If Utils._hasUNOMethod(ControlView, "isVisible") Then _PropertyGet = CBool(ControlView.isVisible())
End Select
Case Else
Goto Trace_Error
End Select

If IsEmpty(_PropertyGet) Then TraceError(TRACEINFO, ERRPROPERTYINIT, Utils._CalledSub(), 0, , psProperty)

Exit_Function:
Utils._ResetCalledSub("Control.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Control._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet V0.9.1
Access2BaseDev Control _PropertySet Basic BackColor (Procedure)
BorderColor (Procedure)
BorderStyle (Procedure)
Cancel (Procedure)
Caption (Procedure)
ControlTipText (Procedure)
Default (Procedure)
DefaultValue (Procedure)
Enabled (Procedure)
FontBold (Procedure)
FontItalic (Procedure)
FontName (Procedure)
FontSize (Procedure)
FontUnderline (Procedure)
FontWeight (Procedure)
ForeColor (Procedure)
Format (Procedure)
ListIndex (Procedure)
Locked (Procedure)
MultiSelect (Procedure)
OnActionPerformed (Procedure)
OnAdjustmentValueChanged (Procedure)
OnApproveAction (Procedure)
OnApproveReset (Procedure)
OnApproveUpdate (Procedure)
OnChanged (Procedure)
OnErrorOccurred (Procedure)
OnFocusGained (Procedure)
OnFocusLost (Procedure)
OnItemStateChanged (Procedure)
OnKeyPressed (Procedure)
OnKeyReleased (Procedure)
OnMouseDragged (Procedure)
OnMouseEntered (Procedure)
OnMouseExited (Procedure)
OnMouseMoved (Procedure)
OnMousePressed (Procedure)
OnMouseReleased (Procedure)
OnResetted (Procedure)
OnTextChanged (Procedure)
OnUpdated (Procedure)
OptionValue (Procedure)
Page (Procedure)
Picture (Procedure)
Required (Procedure)
RowSource (Procedure)
RowSourceType (Procedure)
Selected (Procedure)
SelectedI (Procedure)
SelLength (Procedure)
SelStart (Procedure)
SelText (Procedure)
SpecialEffect (Procedure)
TabIndex (Procedure)
TabStop (Procedure)
Tag (Procedure)
TextAlign (Procedure)
TripleState (Procedure)
Value (Procedure)
Visible (Procedure)
setProperty (Procedure)
611
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean
' Return True if property setting OK

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Control.set" & psProperty)
_PropertySet = True

'Check Index argument
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function
End If
'Execute
Dim iArgNr As Integer, vButton As Variant, i As Integer
Dim odbDatabase As Object, vNames() As Variant, bFound As Boolean, sName As String
Dim bMultiSelect As Boolean, iCount As Integer, iSelectedItems() As Integer, lListCount As Long, bSelected() As Boolean
Dim vItemList() As Variant, vFormats() As Variant
Dim oStruct As Object, sValue As String
Dim vSelection As Variant, sText As String, lStart As long
Dim oControlEvents As Object, sListener As String, sEvent As String, sEventName As String, oEvent As Object

_PropertySet = True
Select Case UCase(_A2B_.CalledSub)
Case UCase("setProperty") : iArgNr = 3
Case UCase("Control.setProperty") : iArgNr = 2
Case UCase("Control.set" & psProperty) : iArgNr = 1
End Select

If Not hasProperty(psProperty) Then Goto Trace_Error

Select Case UCase(psProperty)
Case UCase("BackColor")
If Not Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.BackgroundColor = CLng(pvValue)
Case UCase("BorderColor")
If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.BorderColor = CLng(pvValue)
Case UCase("BorderStyle")
If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = No border, 1 = 3D border, 2 = Normal border
ControlModel.Border = CLng(pvValue)
Case UCase("Cancel")
If Not Utils._hasUNOProperty(ControlModel, "PushButtonType") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then vButton = com.sun.star.awt.PushButtonType.CANCEL Else vButton = com.sun.star.awt.PushButtonType.STANDARD
ControlModel.PushButtonType = vButton
Case UCase("Caption")
If Not Utils._hasUNOProperty(ControlModel, "Label") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.Label = pvValue
Case UCase("ControlTipText")
If Not Utils._hasUNOProperty(ControlModel, "HelpText") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.HelpText = pvValue
Case UCase("Default")
If Not Utils._hasUNOProperty(ControlModel, "DefaultButton") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ControlModel.DefaultButton = pvValue
Case UCase("DefaultValue")
Select Case _SubType
Case CTLDATEFIELD
If Not Utils._hasUNOProperty(ControlModel, "DefaultDate") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
Select Case VarType(ControlModel.DefaultDate)
Case vbEmpty, vbLong ' AOO and LO <= 4.1
ControlModel.DefaultDate = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue)
Case vbObject ' LO >= 4.2 com.sun.star.Util.Date
ControlModel.DefaultDate.Year = Year(pvValue)
ControlModel.DefaultDate.Month = Month(pvValue)
ControlModel.DefaultDate.Day = Day(pvValue)
End Select
Case CTLLISTBOX
If Not Utils._hasUNOProperty(ControlModel, "DefaultSelection") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
For i = 0 To UBound(ControlModel.StringItemList)
If UCase(pvValue) = UCase(ControlModel.StringItemList(i)) Then
ControlModel.DefaultSelection = Array(i)
Exit For
End If
Next i
Case CTLSPINBUTTON
If Not Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.DefaultSpinValue = pvValue
Case CTLCHECKBOX
If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know
ControlModel.DefaultState = pvValue
Case CTLRADIOBUTTON
If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > 1 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked
ControlModel.DefaultState = pvValue
Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD
If Not Utils._hasUNOProperty(ControlModel, "DefaultText") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.DefaultText = pvValue
Case CTLTIMEFIELD
If Not Utils._hasUNOProperty(ControlModel, "DefaultTime") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue >= 0 And pvValue <= 23595999 Then
Select Case VarType(ControlModel.DefaultTime)
Case vbEmpty, vbLong ' AOO and LO <= 4.1
ControlModel.DefaultTime = pvValue
Case vbObject ' LO >= 4.2 com.sun.star.Util.Time
ControlModel.DefaultDate.Hours = Hour(pvValue)
ControlModel.DefaultDate.Minutes = Minute(pvValue)
ControlModel.DefaultDate.Seconds = Second(pvValue)
End Select
Else Goto Trace_Error_Value
End If
Case CTLCURRENCYFIELD, CTLNUMERICFIELD
If Not Utils._hasUNOProperty(ControlModel, "DefaultValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.DefaultValue = pvValue
Case CTLFORMATTEDFIELD
If Not Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.EffectiveDefault = pvValue ' Thanks, PASTIM
Case Else
Goto Trace_Error
End Select
Case UCase("Enabled")
If Not Utils._hasUNOProperty(ControlModel, "Enabled") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ControlModel.Enabled = pvValue
Case UCase("FontBold")
If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then ' Iif construction does not work !
ControlModel.FontWeight = com.sun.star.awt.FontWeight.BOLD
Else
ControlModel.FontWeight = com.sun.star.awt.FontWeight.NORMAL
End If
Case UCase("FontItalic")
If Not Utils._hasUNOProperty(ControlModel, "FontSlant") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then ' Iif construction does not work !
ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC
Else
ControlModel.FontSlant = com.sun.star.awt.FontSlant.NONE
End If
Case UCase("FontName")
If Not Utils._hasUNOProperty(ControlModel, "FontName") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.FontName = pvValue
Case UCase("FontSize")
If Not Utils._hasUNOProperty(ControlModel, "FontHeight") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 1 Or pvValue > 127 Then Goto Trace_Error_Value
ControlModel.FontHeight = pvValue
Case UCase("FontUnderline")
If Not Utils._hasUNOProperty(ControlModel, "FontUnderline") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then ' Iif construction does not work !
ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.SINGLE
Else
ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE
End If
Case UCase("FontWeight")
If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error
If Not Utils._IsScalar(CSng(pvValue), vbSingle, Array( _
com.sun.star.awt.FontWeight.THIN _
, com.sun.star.awt.FontWeight.ULTRALIGHT _
, com.sun.star.awt.FontWeight.LIGHT _
, com.sun.star.awt.FontWeight.SEMILIGHT _
, com.sun.star.awt.FontWeight.NORMAL _
, com.sun.star.awt.FontWeight.SEMIBOLD _
, com.sun.star.awt.FontWeight.BOLD _
, com.sun.star.awt.FontWeight.ULTRABOLD _
, com.sun.star.awt.FontWeight.BLACK _
)) Then Goto Trace_Error_Value
ControlModel.FontWeight = pvValue
Case UCase("Format")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
vFormats = _Formats(_SubType)
Select Case _SubType
Case CTLDATEFIELD, CTLTIMEFIELD
bFound = False
For i = 0 To UBound(vFormats)
If UCase(pvValue) = UCase(vFormats(i)) Then
If _SubType = CTLDATEFIELD Then
If Utils._hasUNOProperty(ControlModel, "DateFormat") Then ControlModel.DateFormat = i Else Goto Trace_Error
Else
If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then ControlModel.TimeFormat = i Else Goto Trace_Error
End If
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_Error_Value
Case Else
Goto Trace_Error
End Select
Case UCase("ForeColor")
If Not Utils._hasUNOProperty(ControlModel, "TextColor") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.TextColor = CLng(pvValue)
Case UCase("ListIndex")
If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Value
Select Case _SubType
Case CTLCOMBOBOX
ControlModel.Text = ControlModel.StringItemList(pvValue)
Case CTLLISTBOX
ControlModel.SelectedItems = Array(pvValue)
End Select
Case UCase("Locked")
If Not Utils._hasUNOProperty(ControlModel, "ReadOnly") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ControlModel.ReadOnly = pvValue
Case UCase("MultiSelect")
If Not Utils._hasUNOProperty(ControlModel, "MultiSelection") And Not Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then
ControlModel.MultiSelection = pvValue
ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then
ControlModel.MultiSelectionSimpleMode = pvValue
End If
If Not pvValue Then ControlModel.SelectedItems = Array() ' Cancel selections when MultiSelect becomes False
Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _
, UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _
, UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
, UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
, UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _
, UCase("OnUpdated")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
Select Case _ParentType
Case CTLPARENTISDIALOG
If Not Utils._RegisterDialogEventScript(ControlModel _
, psProperty _
, _GetListener(psProperty) _
, pvValue _
) Then GoTo Trace_Error
Case Else
If Not Utils._RegisterEventScript(ControlModel _
, psProperty _
, _GetListener(psProperty) _
, pvValue _
, _Name _
) Then GoTo Trace_Error
End Select
Case UCase("OptionValue")
If Not Utils._hasUNOProperty(ControlModel, "RefValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If Not Utils._hasUNOProperty(ControlModel, "Label") Then
If pvValue = "" Then Goto Trace_Error_Value
If ControlModel.RefValue <> "" Then ControlModel.RefValue = pvValue
Else
ControlModel.Label = pvValue
End If
Case UCase("Page")
If Not Utils._hasUNOProperty(ControlModel, "Step") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Then Goto Trace_Error_Value
ControlModel.Step = pvValue
Case UCase("Picture")
If Not Utils._hasUNOProperty(ControlModel, "ImageURL") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.ImageURL = ConvertToUrl(pvValue)
Case UCase("Required")
If Not Utils._hasUNOProperty(ControlModel, "InputRequired") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ControlModel.InputRequired = pvValue
Case UCase("RowSource")
Select Case _ParentType
Case CTLPARENTISDIALOG
If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error
ControlModel.StringItemList = Split(pvValue, ";")
Case Else
If Not Utils._hasUNOProperty(ControlModel, "ListSource") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
Select Case ControlModel.ListSourceType
Case com.sun.star.form.ListSourceType.QUERY _
, com.sun.star.form.ListSourceType.TABLE _
, com.sun.star.form.ListSourceType.TABLEFIELDS
Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
If ControlModel.ListSourceType = com.sun.star.form.ListSourceType.QUERY Then vNames = odbDatabase.Connection.getQueries.GetElementNames _
Else vNames = odbDatabase.Connection.getTables.GetElementNames
bFound = False ' Check existence of table or query and find its correct (case-sensitive) name
For i = 0 To UBound(vNames)
If UCase(vNames(i)) = UCase(pvValue) Then
bFound = True
sName = vNames(i)
Exit For
End If
Next i
If Not bFound Then Goto Trace_Error_Value
If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = sName Else ControlModel.ListSource = Array(sName)
ControlModel.refresh()
Case com.sun.star.form.ListSourceType.SQL
Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = odbDatabase._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(odbDatabase._ReplaceSquareBrackets(pvValue))
ControlModel.refresh()
Case com.sun.star.form.ListSourceType.VALUELIST ' Forbidden for COMBOBOX !
If _SubType = CTLCOMBOBOX Then Goto Trace_Error
ControlModel.ListSource = Split(pvValue, ";")
ControlModel.StringItemList = ControlModel.ListSource
Case com.sun.star.form.ListSourceType.SQLPASSTHROUGH
If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = pvValue Else ControlModel.ListSource = Array(pvValue)
ControlModel.refresh()
End Select
End Select
If _SubType = CTLLISTBOX Then ControlModel.SelectedItems = Array()
Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType
If Not Utils._hasUNOProperty(ControlModel, "ListSourceType") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Not Utils._IsScalar(pvValue, Utils._AddNumeric(), Array( _
com.sun.star.form.ListSourceType.VALUELIST _
, com.sun.star.form.ListSourceType.TABLE _
, com.sun.star.form.ListSourceType.QUERY _
, com.sun.star.form.ListSourceType.SQL _
, com.sun.star.form.ListSourceType.SQLPASSTHROUGH _
, com.sun.star.form.ListSourceType.TABLEFIELDS _
)) Then Goto Trace_Error_Value
ControlModel.ListSourceType = pvValue
Case UCase("Selected")
If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error
If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error
If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then
bMultiSelect = ControlModel.MultiSelection
ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then
bMultiSelect = ControlModel.MultiSelectionSimpleMode
Else: Goto Trace_Error
End If
lListCount = UBound(ControlModel.StringItemList) + 1
If IsMissing(pvIndex) Then ' Full boolean array passed
If Not IsArray(pvValue) Then Goto Trace_Error_Array
If LBound(pvValue) <> 0 Or UBound(pvValue) < 0 Then Goto Trace_Error_Array
If Not Utils._CheckArgument(pvValue(0), iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If UBound(pvValue) <> lListCount - 1 Then Goto Trace_Error_Index
iCount = 0
For i = 0 To UBound(pvValue) ' Count True values
If pvValue(i) Then iCount = iCount + 1
Next i
If iCount > 0 Then
Redim iSelectedItems(0 To iCount - 1)
iCount = 0
For i = 0 To UBound(pvValue)
If pvValue(i) Then
iSelectedItems(iCount) = i
iCount = iCount + 1
End If
Next i
ControlModel.SelectedItems = iSelectedItems ' iSelectedItems maps OO internals (size = # of selected items)
Else
ControlModel.SelectedItems = Array()
End If
Else ' Single boolean value passed
If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function
If pvIndex < 0 Or pvIndex >= lListCount Then Goto Trace_Error_Index
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ReDim bSelected(0 To lListCount - 1) ' bSelected maps VBA internals (size = # of displayed items)
If Not bMultiSelect Then ' Set all other values to False
For i = 0 To lListCount - 1
If i = pvIndex Then
bSelected(i) = pvValue ' All entries = False except one
Else
bSelected(i) = False
End If
Next i
Else
For i = 0 To lListCount - 1
bSelected(i) = False
Next i
iSelectedItems = ControlModel.SelectedItems
iCount = UBound(iSelectedItems)
For i = 0 To iCount
bSelected(iSelectedItems(i)) = True
Next i
bSelected(pvIndex) = pvValue
End If
iCount = 0 ' Rebuild SelectedItems
For i = 0 To lListCount - 1
If bSelected(i) Then iCount = iCount + 1
Next i
If iCount > 0 Then
Redim iSelectedItems(0 To iCount - 1)
iCount = 0
For i = 0 To lListCount - 1
If bSelected(i) Then
iSelectedItems(iCount) = i
iCount = iCount + 1
End If
Next i
ControlModel.SelectedItems = iSelectedItems
Else
ControlModel.SelectedItems = Array()
End If
End If
Case UCase("SelLength")
If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Then Goto Trace_Error_Value
vSelection = ControlView.getSelection()
vSelection.Max = vSelection.Min + pvValue
ControlView.setSelection(vSelection)
Case UCase("SelStart")
If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 1 Or pvValue > Len(ControlModel.Text) + 1 Then Goto Trace_Error_Value
vSelection = ControlView.getSelection()
vSelection.Min = pvValue - 1
vSelection.Max = pvValue - 1 ' Also reset length to 0
ControlView.setSelection(vSelection)
Case UCase("SelText")
If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error
If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If Len(pvValue) > 0 Then
vSelection = ControlView.getSelection()
sText = ControlModel.Text
lStart = InStr(1, sText, pvValue, 0) ' Case sensitive !
If lStart > 0 Then
vSelection.Min = lStart - 1
vSelection.Max = lStart + Len(pvValue) - 1
ControlView.setSelection(vSelection)
End If
End If
Case UCase("SpecialEffect")
If Not Utils._hasUNOProperty(ControlModel, "VisualEffect") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = None, 1 = Look3D, 2 = Flat
ControlModel.VisualEffect = pvValue
Case UCase("TabIndex")
If Not Utils._hasUNOProperty(ControlModel, "TabIndex") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < -1 Then Goto Trace_Error_Value
ControlModel.TabIndex = pvValue
Case UCase("TabStop")
If Not Utils._hasUNOProperty(ControlModel, "Tabstop") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ControlModel.Tabstop = pvValue
Case UCase("Tag")
If Not Utils._hasUNOProperty(ControlModel, "Tag") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.Tag = pvValue
Case UCase("TextAlign")
If Not Utils._hasUNOProperty(ControlModel, "Align") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Left, 1 = Center, 2 = Right
ControlModel.Align = pvValue
Case UCase("TripleState")
If Not Utils._hasUNOProperty(ControlModel, "TriState") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ControlModel.TriState = pvValue
Case UCase("Value")
Select Case _SubType
Case CTLCHECKBOX
If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbBoolean), , False) Then Goto Trace_Error_Value
If VarType(pvValue) = vbBoolean Then pvValue = Iif(pvValue, 1, 0)
If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know
ControlModel.State = pvValue
Case CTLCOMMANDBUTTON
If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error
If Not Utils._hasUNOProperty(ControlModel, "Toggle") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then ControlModel.State = 1 Else ControlModel.State = 0
Case CTLCOMBOBOX
If Not Utils._hasUNOProperty(ControlModel, "Text") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _
Then Goto Trace_Error
If pvValue <> "" Then
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, ControlModel.StringItemList, False) Then Goto Trace_Error_Value
End If
ControlModel.Text = pvValue
Case CTLCURRENCYFIELD, CTLNUMERICFIELD
If Not Utils._hasUNOProperty(ControlModel, "Value") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
ControlModel.Value = pvValue
Case CTLDATEFIELD
If Not Utils._hasUNOProperty(ControlModel, "Date") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
Select Case _InspectPropertyType(ControlModel, "Date")
Case "long" ' AOO and LO <= 4.1
'ControlModel.Date = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) ' Gives error in dialogs ?!?
ControlModel.setPropertyValue("Date", Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue))
Case "com.sun.star.util.Date" ' LO >= 4.2
'Direct assignment of ControlModel.Date.Xxx has no effect ?!?
Set oStruct = CreateUnoStruct("com.sun.star.util.Date")
oStruct.Year = Year(pvValue)
oStruct.Month = Month(pvValue)
oStruct.Day = Day(pvValue)
Set ControlModel.Date = oStruct
End Select
Case CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD
If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
ControlModel.Text = pvValue
Case CTLFORMATTEDFIELD
If Not Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbString), , False) Then Goto Trace_Error_Value
ControlModel.EffectiveValue = pvValue
Case CTLHIDDENCONTROL
If Not Utils._hasUNOProperty(ControlModel, "HiddenValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbBoolean, vbDate)), , False) Then Goto Trace_Error_Value
ControlModel.HiddenValue = pvValue
Case CTLLISTBOX
If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _
Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbDate)), , False) Then Goto Trace_Error_Value ' PASTIM
If IsArray(pvValue) Then Goto Trace_Error_Value ' Setting the value on a listbox is allowed only if single value and value in the list
' Check ValueItemList
bFound = False
Select Case _ParentType
Case CTLPARENTISDIALOG
vItemList = ControlModel.StringItemList
Case Else
If _ListboxBound() Then ' Performance improvement (PASTIM PM 9 Feb 2013)
If Not Utils._hasUNOProperty(ControlModel, "ValueItemList") Then Goto Trace_Error
vItemList = ControlModel.ValueItemList
Else
vItemList = ControlModel.StringItemList
End If
End Select
For i = 0 To UBound(vItemList)
If pvValue = vItemList(i) Then
bFound = True
Exit For
End If
Next i
If bFound Then ControlModel.SelectedItems = Array(i) Else Goto Trace_Error_Value
Case CTLPROGRESSBAR
If Not Utils._hasUNOProperty(ControlModel, "ProgressValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(ControlModel, "ProgressValueMin") Then
If pvValue < ControlModel.ProgressValueMin Then Goto Trace_Error_Value
End If
If Utils._hasUNOProperty(ControlModel, "ProgressValueMax") Then
If pvValue > ControlModel.ProgressValueMax Then Goto Trace_Error_Value
End If
ControlModel.ProgressValue = pvValue
Case CTLSCROLLBAR
If Not Utils._hasUNOProperty(ControlModel, "ScrollValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(ControlModel, "ScrollValueMin") Then
If pvValue < ControlModel.ScrollValueMin Then Goto Trace_Error_Value
End If
If Utils._hasUNOProperty(ControlModel, "ScrollValueMax") Then
If pvValue > ControlModel.ScrollValueMax Then Goto Trace_Error_Value
End If
ControlModel.ScrollValue = pvValue
Case CTLSPINBUTTON
If Not Utils._hasUNOProperty(ControlModel, "SpinValue") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(ControlModel, "SpinValueMin") Then
If pvValue < ControlModel.SpinValueMin Then Goto Trace_Error_Value
End If
If Utils._hasUNOProperty(ControlModel, "SpinValueMax") Then
If pvValue > ControlModel.SpinValueMax Then Goto Trace_Error_Value
End If
ControlModel.SpinValue = pvValue
Case CTLTIMEFIELD
If Not Utils._hasUNOProperty(ControlModel, "Time") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
Select Case _InspectPropertyType(ControlModel, "Time")
Case "long" ' AOO and LO <= 4.0
ControlModel.Time = CLng(pvValue)
Case "com.sun.star.util.Time" ' LO >= 4.1
'Direct assignment of ControlModel.Time.Xxx gives error ?!?
Set oStruct = CreateUnoStruct("com.sun.star.util.Time")
sValue = Right("00000000" & Str(CLng(pvValue)), 8)
oStruct.Hours = Val(Left(sValue, 2))
oStruct.Minutes = Val(Mid(sValue, 3, 2))
oStruct.Seconds = Val(Mid(sValue, 5, 2))
Set ControlModel.Time = oStruct
End Select
Case Else
Goto Trace_Error
End Select
' FINAL COMMITMENT
If Utils._hasUNOMethod(ControlModel, "commit") Then ControlModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM]
Case UCase("Visible")
If _SubType = CTLHIDDENCONTROL Then Goto Trace_Error ' Hidden remains hidden !!
If Not Utils._hasUNOMethod(ControlView, "setVisible") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then ControlModel.EnableVisible = True
ControlView.setVisible(pvValue)
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Control.set" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Array:
TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr)
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Control._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet V1.1.0
Access2BaseDev Control AddItem Basic   56
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
Access2BaseDev Control BackColor Basic   6
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)
Access2BaseDev Control BorderColor Basic   7
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)
Access2BaseDev Control BorderStyle Basic   7
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)
Access2BaseDev Control Cancel Basic   7
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)
Access2BaseDev Control Caption Basic   7
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)
Access2BaseDev Control Class_Initialize Basic Class_Terminate (Procedure) 21
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJCONTROL
_ClassId = -1
_ParentType = ""
_Shortcut = ""
_Name = ""
Set _FormComponent = Nothing
_MainForm = ""
_DocEntry = -1
_DbEntry = -1
_ThisProperties = Array()
_SubType = ""
Set ControlModel = Nothing
Set ControlView = Nothing
Set BoundField = Nothing
Set LabelControl = Nothing

End Sub ' Constructor
Access2BaseDev Control Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Control Controls Basic   97
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
' Return a Control object with name or index = pvIndex

Const cstThisSub = "Control.Controls"
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)

Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer
Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String
Dim j As Integer, oView As Object

If _SubType <> CTLGRIDCONTROL Then Goto Trace_Error_Context
Set ocControl = Nothing
iControlCount = ControlModel.getCount()

If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object
Set oCounter = New Collect
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

With ocControl
._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name)
Set .ControlModel = ControlModel.getByName(._Name)
._ImplementationName = .ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !?
._FormComponent = ParentComponent
._MainForm = _MainForm
If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId
' Complex bypass to find View of grid subcontrols !
If Not IsNull(ControlView) Then ' Anticipate absence of ControlView in grid controls when edit mode
For i = 0 to ControlView.getCount() - 1
Set oView = ControlView.GetByIndex(i)
If Not IsNull(oView) Then
If oView.getModel.Name = ._Name Then
Set .ControlView = oView
Exit For
End If
End If
Next i
End If

._Initialize()
._DocEntry = _DocEntry
._DbEntry = _DbEntry
End With
Set Controls = ocControl

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set Controls = Nothing
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name))
Set Controls = Nothing
Goto Exit_Function
Trace_Error_Context:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Grid.Controls")
Set Controls = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Set Controls = Nothing
GoTo Exit_Function
End Function ' Controls
Access2BaseDev Control ControlSource Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ControlSource() As Variant
ControlSource = _PropertyGet("ControlSource")
End Property ' ControlSource (get)
Access2BaseDev Control ControlTipText Basic   7
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)
Access2BaseDev Control ControlType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ControlType() As Variant
ControlType = _PropertyGet("ControlType")
End Property ' ControlType (get)
Access2BaseDev Control Default Basic   7
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)
Access2BaseDev Control DefaultValue Basic   7
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)
Access2BaseDev Control Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Control Enabled Basic   7
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)
Access2BaseDev Control FontBold Basic   7
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)
Access2BaseDev Control FontItalic Basic   7
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)
Access2BaseDev Control FontName Basic   7
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)
Access2BaseDev Control FontSize Basic   7
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)
Access2BaseDev Control FontUnderline Basic   7
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)
Access2BaseDev Control FontWeight Basic   7
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)
Access2BaseDev Control ForeColor Basic   7
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)
Access2BaseDev Control Form Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Form() As Variant
Form = _PropertyGet("Form")
End Property ' Form (get)
Access2BaseDev Control Format Basic   7
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)
Access2BaseDev Control getProperty Basic   14
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
Access2BaseDev Control hasProperty Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
8
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
Access2BaseDev Control ItemData Basic   4
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)
Access2BaseDev Control ListCount Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ListCount() As Variant
ListCount = _PropertyGet("ListCount")
End Property ' ListCount (get)
Access2BaseDev Control ListIndex Basic   7
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)
Access2BaseDev Control Locked Basic   7
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)
Access2BaseDev Control MultiSelect Basic   7
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)
Access2BaseDev Control Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Control ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Control OnActionPerformed Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnActionPerformed() As Variant
OnActionPerformed = _PropertyGet("OnActionPerformed")
End Property ' OnActionPerformed (get)

Property Let OnActionPerformed(ByVal pvValue As Variant)
Call _PropertySet("OnActionPerformed", pvValue)
End Property ' OnActionPerformed (set)
Access2BaseDev Control OnAdjustmentValueChanged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnAdjustmentValueChanged() As Variant
OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged")
End Property ' OnAdjustmentValueChanged (get)

Property Let OnAdjustmentValueChanged(ByVal pvValue As Variant)
Call _PropertySet("OnAdjustmentValueChanged", pvValue)
End Property ' OnAdjustmentValueChanged (set)
Access2BaseDev Control OnApproveAction Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveAction() As Variant
OnApproveAction = _PropertyGet("OnApproveAction")
End Property ' OnApproveAction (get)

Property Let OnApproveAction(ByVal pvValue As Variant)
Call _PropertySet("OnApproveAction", pvValue)
End Property ' OnApproveAction (set)
Access2BaseDev Control OnApproveReset Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveReset() As Variant
OnApproveReset = _PropertyGet("OnApproveReset")
End Property ' OnApproveReset (get)

Property Let OnApproveReset(ByVal pvValue As Variant)
Call _PropertySet("OnApproveReset", pvValue)
End Property ' OnApproveReset (set)
Access2BaseDev Control OnApproveUpdate Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveUpdate() As Variant
OnApproveUpdate = _PropertyGet("OnApproveUpdate")
End Property ' OnApproveUpdate (get)

Property Let OnApproveUpdate(ByVal pvValue As Variant)
Call _PropertySet("OnApproveUpdate", pvValue)
End Property ' OnApproveUpdate (set)
Access2BaseDev Control OnChanged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnChanged() As Variant
OnChanged = _PropertyGet("OnChanged")
End Property ' OnChanged (get)

Property Let OnChanged(ByVal pvValue As Variant)
Call _PropertySet("OnChanged", pvValue)
End Property ' OnChanged (set)
Access2BaseDev Control OnErrorOccurred Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnErrorOccurred() As Variant
OnErrorOccurred = _PropertyGet("OnErrorOccurred")
End Property ' OnErrorOccurred (get)

Property Let OnErrorOccurred(ByVal pvValue As Variant)
Call _PropertySet("OnErrorOccurred", pvValue)
End Property ' OnErrorOccurred (set)
Access2BaseDev Control OnFocusGained Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnFocusGained() As Variant
OnFocusGained = _PropertyGet("OnFocusGained")
End Property ' OnFocusGained (get)

Property Let OnFocusGained(ByVal pvValue As Variant)
Call _PropertySet("OnFocusGained", pvValue)
End Property ' OnFocusGained (set)
Access2BaseDev Control OnFocusLost Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnFocusLost() As Variant
OnFocusLost = _PropertyGet("OnFocusLost")
End Property ' OnFocusLost (get)

Property Let OnFocusLost(ByVal pvValue As Variant)
Call _PropertySet("OnFocusLost", pvValue)
End Property ' OnFocusLost (set)
Access2BaseDev Control OnItemStateChanged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnItemStateChanged() As Variant
OnItemStateChanged = _PropertyGet("OnItemStateChanged")
End Property ' OnItemStateChanged (get)

Property Let OnItemStateChanged(ByVal pvValue As Variant)
Call _PropertySet("OnItemStateChanged", pvValue)
End Property ' OnItemStateChanged (set)
Access2BaseDev Control OnKeyPressed Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnKeyPressed() As Variant
OnKeyPressed = _PropertyGet("OnKeyPressed")
End Property ' OnKeyPressed (get)

Property Let OnKeyPressed(ByVal pvValue As Variant)
Call _PropertySet("OnKeyPressed", pvValue)
End Property ' OnKeyPressed (set)
Access2BaseDev Control OnKeyReleased Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnKeyReleased() As Variant
OnKeyReleased = _PropertyGet("OnKeyReleased")
End Property ' OnKeyReleased (get)

Property Let OnKeyReleased(ByVal pvValue As Variant)
Call _PropertySet("OnKeyReleased", pvValue)
End Property ' OnKeyReleased (set)
Access2BaseDev Control OnMouseDragged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseDragged() As Variant
OnMouseDragged = _PropertyGet("OnMouseDragged")
End Property ' OnMouseDragged (get)

Property Let OnMouseDragged(ByVal pvValue As Variant)
Call _PropertySet("OnMouseDragged", pvValue)
End Property ' OnMouseDragged (set)
Access2BaseDev Control OnMouseEntered Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseEntered() As Variant
OnMouseEntered = _PropertyGet("OnMouseEntered")
End Property ' OnMouseEntered (get)

Property Let OnMouseEntered(ByVal pvValue As Variant)
Call _PropertySet("OnMouseEntered", pvValue)
End Property ' OnMouseEntered (set)
Access2BaseDev Control OnMouseExited Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseExited() As Variant
OnMouseExited = _PropertyGet("OnMouseExited")
End Property ' OnMouseExited (get)

Property Let OnMouseExited(ByVal pvValue As Variant)
Call _PropertySet("OnMouseExited", pvValue)
End Property ' OnMouseExited (set)
Access2BaseDev Control OnMouseMoved Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseMoved() As Variant
OnMouseMoved = _PropertyGet("OnMouseMoved")
End Property ' OnMouseMoved (get)

Property Let OnMouseMoved(ByVal pvValue As Variant)
Call _PropertySet("OnMouseMoved", pvValue)
End Property ' OnMouseMoved (set)
Access2BaseDev Control OnMousePressed Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMousePressed() As Variant
OnMousePressed = _PropertyGet("OnMousePressed")
End Property ' OnMousePressed (get)

Property Let OnMousePressed(ByVal pvValue As Variant)
Call _PropertySet("OnMousePressed", pvValue)
End Property ' OnMousePressed (set)
Access2BaseDev Control OnMouseReleased Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseReleased() As Variant
OnMouseReleased = _PropertyGet("OnMouseReleased")
End Property ' OnMouseReleased (get)

Property Let OnMouseReleased(ByVal pvValue As Variant)
Call _PropertySet("OnMouseReleased", pvValue)
End Property ' OnMouseReleased (set)
Access2BaseDev Control OnResetted Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnResetted() As Variant
OnResetted = _PropertyGet("OnResetted")
End Property ' OnResetted (get)

Property Let OnResetted(ByVal pvValue As Variant)
Call _PropertySet("OnResetted", pvValue)
End Property ' OnResetted (set)
Access2BaseDev Control OnTextChanged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnTextChanged() As Variant
OnTextChanged = _PropertyGet("OnTextChanged")
End Property ' OnTextChanged (get)

Property Let OnTextChanged(ByVal pvValue As Variant)
Call _PropertySet("OnTextChanged", pvValue)
End Property ' OnTextChanged (set)
Access2BaseDev Control OnUpdated Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUpdated() As Variant
OnUpdated = _PropertyGet("OnUpdated")
End Property ' OnUpdated (get)

Property Let OnUpdated(ByVal pvValue As Variant)
Call _PropertySet("OnUpdated", pvValue)
End Property ' OnUpdated (set)
Access2BaseDev Control OptionValue Basic   7
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)
Access2BaseDev Control Page Basic   7
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)
Access2BaseDev Control Parent Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Parent() As Object
Parent = _PropertyGet("Parent")
End Function ' Parent (get) V0.9.1
Access2BaseDev Control Picture Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Picture() As Variant
Picture = _PropertyGet("Picture")
End Property ' Picture (get)

Property Let Picture(ByVal pvValue As Variant)
Call _PropertySet("Picture", pvValue)
End Property ' Picture (set) V1.5.0
Access2BaseDev Control pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev Control Properties Basic   22
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
Access2BaseDev Control pText Basic   3
Public Function pText() As variant
pText = _PropertyGet("Text")
End Function ' pText (get)
Access2BaseDev Control RemoveItem Basic   75
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RemoveItem(ByVal Optional pvIndex) As Boolean
' Remove an item from a Listbox
' Index may be a string value or an index-position

Utils._SetCalledSub("Control.RemoveItem")
If _ErrorHandler() Then On Local Error Goto Error_Function

If IsMissing(pvIndex) Then Call _TraceArguments()
Dim iArgNr As Integer
Select Case UCase(_A2B_.CalledSub)
Case UCase("RemoveItem") : iArgNr = 1
Case UCase("Control.RemoveItem") : iArgNr = 0
End Select
If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
If _SubType <> CTLLISTBOX Then Goto Error_Control
If _ParentType <> CTLPARENTISDIALOG Then
If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control
End If

Dim vRowSource() As Variant, iCount As Integer, i As Integer, j As integer, bFound As Boolean
If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList)
iCount = UBound(vRowSource)

Select Case VarType(pvIndex)
Case vbString
bFound = False
For i = 0 To iCount
If vRowSource(i) = pvIndex Then
For j = i To iCount - 1
vRowSource(j) = vRowSource(j + 1)
Next j
bFound = True
Exit For ' Remove only 1st occurrence of string
End If
Next i
Case Else
If pvIndex < 0 Or pvIndex > iCount Then Goto Error_Index
For i = pvIndex To iCount - 1
vRowSource(i) = vRowSource(i + 1)
Next i
bFound = True
End Select

If bFound Then
If iCount > 0 Then ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=75008
ReDim Preserve vRowSource(0 To iCount - 1)
Else
vRowSource = Array()
End If
If _ParentType <> CTLPARENTISDIALOG Then
ControlModel.ListSource = vRowSource()
End If
ControlModel.StringItemList = vRowSource()
RemoveItem = True
Else
RemoveItem = False
End If

Exit_Function:
Utils._ResetCalledSub("Control.RemoveItem")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Control.RemoveItem", Erl)
RemoveItem = False
GoTo Exit_Function
Error_Control:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.RemoveItem")
RemoveItem = False
Goto Exit_Function
Error_Index:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(2, pvIndex))
RemoveItem = False
Goto Exit_Function
End Function ' RemoveItem V0.9.1
Access2BaseDev Control Requery Basic   34
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Requery() As Boolean
' Refresh data displayed in a form, subform, combobox or listbox
Utils._SetCalledSub("Control.Requery")
If _ErrorHandler() Then On Local Error Goto Error_Function
Requery = False

Select Case _SubType
Case CTLCOMBOBOX, CTLLISTBOX
If Utils._InList(ControlModel.ListSourceType, Array( _
com.sun.star.form.ListSourceType.QUERY _
, com.sun.star.form.ListSourceType.TABLE _
, com.sun.star.form.ListSourceType.TABLEFIELDS _
, com.sun.star.form.ListSourceType.SQL _
, com.sun.star.form.ListSourceType.SQLPASSTHROUGH _
)) Then
ControlModel.refresh()
End If
Case Else
Goto Error_Control
End Select
Requery = True

Exit_Function:
Utils._ResetCalledSub("Control.Requery")
Exit Function
Error_Control:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.Requery")
Requery = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Control.Requery", Erl)
GoTo Exit_Function
End Function ' Requery
Access2BaseDev Control Required Basic   7
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)
Access2BaseDev Control RowSource Basic   7
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)
Access2BaseDev Control RowSourceType Basic   7
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)
Access2BaseDev Control Selected Basic   8
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)
Access2BaseDev Control SelectedI Basic   3
Public Function SelectedI(ByVal pvValue As variant, ByVal pvIndex As Variant)
Call _PropertySet("Selected", pvValue, pvIndex)
End Function
Access2BaseDev Control SelLength Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SelLength() As Variant
SelLength = _PropertyGet("SelLength")
End Property ' SelLength (get)

Property Let SelLength(ByVal pvValue As Variant)
Call _PropertySet("SelLength", pvValue)
End Property ' SelLength (set)
Access2BaseDev Control SelStart Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SelStart() As Variant
SelStart = _PropertyGet("SelStart")
End Property ' SelStart (get)

Property Let SelStart(ByVal pvValue As Variant)
Call _PropertySet("SelStart", pvValue)
End Property ' SelStart (set)
Access2BaseDev Control SelText Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SelText() As Variant
SelText = _PropertyGet("SelText")
End Property ' SelText (get)

Property Let SelText(ByVal pvValue As Variant)
Call _PropertySet("SelText", pvValue)
End Property ' SelText (set)
Access2BaseDev Control setFocus Basic   46
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFocus() As Boolean
' Execute setFocus method
Utils._SetCalledSub("Control.setFocus")
If _ErrorHandler() Then On Local Error Goto Error_Function
setFocus = False

Dim i As Integer, j As Integer, iColPosition As Integer
Dim ocControl As Object, ocGrid As Variant, oGridModel As Object

If IsNull(ControlView) Then GoTo Exit_Function
If _ParentType = CTLPARENTISGRID Then 'setFocus method does not work on controlviews in grid ?!?
' Find column position of control
iColPosition = -1
ocGrid = getObject(_getUpperShortcut(_Shortcut, _Name)) ' return containing grid
Set oGridModel = ocGrid.ControlModel
j = -1
For i = 0 To oGridModel.Count - 1
Set ocControl = oGridModel.GetByIndex(i)
If Not ocControl.Hidden Then j = j + 1 ' Skip if hidden
If oGridModel.GetByIndex(i).Name = _Name Then
iColPosition = j
Exit For
End If
Next i
If iColPosition >= 0 Then
ocGrid.ControlView.setFocus() 'Set first focus on grid itself
ocGrid.ControlView.setCurrentColumnPosition(iColPosition) 'Deprecated but no alternative found
Else
Goto Error_Grid
End If
Else
ControlView.setFocus()
End If
setFocus = True

Exit_Function:
Utils._ResetCalledSub("Control.setFocus")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Control.setFocus", Erl)
Goto Exit_Function
Error_Grid:
TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(_Name, ocGrid._Name))
Goto Exit_Function
End Function ' setFocus V0.9.0
Access2BaseDev Control setProperty Basic   11
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
Access2BaseDev Control SpecialEffect Basic   7
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)
Access2BaseDev Control SubType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SubType() As Variant
SubType = _PropertyGet("SubType")
End Property ' SubType (get)
Access2BaseDev Control TabIndex Basic   7
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)
Access2BaseDev Control TabStop Basic   7
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)
Access2BaseDev Control Tag Basic   7
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)
Access2BaseDev Control Text Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Text() As Variant
Text = _PropertyGet("Text")
End Property ' Text (get)
Access2BaseDev Control TextAlign Basic   7
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)
Access2BaseDev Control TripleState Basic   7
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)
Access2BaseDev Control Value Basic   7
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)
Access2BaseDev Control Visible Basic   7
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)
Access2BaseDev Database _DFunction Basic DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
70
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _DFunction(ByVal psFunction As String _
, ByVal psExpr As String _
, ByVal psDomain As String _
, ByVal pvCriteria As Variant _
, ByVal Optional pvOrderClause As Variant _
) As Variant
'Arguments: psFunction an optional aggregate function
' psExpr: an SQL expression [might contain an aggregate function]
' psDomain: a table- or queryname
' pvCriteria: an optional WHERE clause
' pcOrderClause: an optional order clause incl. "DESC" if relevant

If _ErrorHandler() Then On Local Error GoTo Error_Function

Dim oResult As Object 'To retrieve the value to find.
Dim vResult As Variant 'Return value for function.
Dim sSql As String 'SQL statement.
Dim oStatement As Object 'For CreateStatement method
Dim sExpr As String 'For inclusion of aggregate function
Dim sTempField As String 'Random temporary field in SQL expression

Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String

vResult = Null

Randomize 2^14-1
sTempField = "[TEMP" & Right("00000" & Int(100000 * Rnd), 5) & "]"
If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = ""
If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = ""
sLimit = ""

Select Case UCase(MetaData.getDatabaseProductName())
Case "MYSQL", "SQLITE"
If psFunction = "" Then
sTarget = psExpr
sLimit = " LIMIT 1"
Else
sTarget = UCase(psFunction) & "(" & psExpr & ")"
End If
sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy & sLimit
Case Else ' Standard syntax - Includes HSQLDB
If psFunction = "" Then sTarget = "TOP 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
End Select

'Lookup the value.
Set oStatement = Connection.createStatement()
With oStatement
.ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
.ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
.EscapeProcessing = False
sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string
Set oResult = .executeQuery(sSql)
If Not IsNull(oResult) And Not IsEmpty(oResult) Then
If Not oResult.next() Then Goto Exit_Function
vResult = Utils._getResultSetColumnValue(oResult, 1, True) ' Force return of binary field
End If
End With

Exit_Function:
'Assign the returned value.
_DFunction = vResult
Set oResult = Nothing
Set oStatement = Nothing
Exit Function
Error_Function:
TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
Goto Exit_Function
End Function ' DFunction V1.5.0
Access2BaseDev Database _FilterOptionsDefault Basic _OutputToCalc (Procedure) 15
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String
' Return the default FilterOptions string for table/query export to csv

Dim sFieldSeparator as string
Const cstComma = ","
Const cstTextDelimitor = """"

If _DecimalPoint() = "," Then sFieldSeparator = ";" Else sFieldSeparator = cstComma
_FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _
& cstComma & Trim(Str(Asc(cstTextDelimitor))) _
& cstComma & Trim(Str(plEncoding)) _
& cstComma & "1"

End Function ' _FilterOptionsDefault V1.4.0
Access2BaseDev Database _hasRecordset Basic Recordsets (Procedure) 15
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasRecordset(ByVal psName As String) As Boolean
' Return True if psName if in the collection of Recordsets

Dim oRecordset As Object
If _ErrorHandler() Then On Local Error Goto Error_Function
Set oRecordset = RecordsetsColl.Item(psName)
_hasRecordset = True

Exit_Function:
Exit Function
Error_Function: ' Item by key aborted
_hasRecordset = False
GoTo Exit_Function
End Function ' _hasRecordset V0.9.5
Access2BaseDev Database _LoadMetadata Basic   117
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _LoadMetadata()
' Load essentially getTypeInfo() results from Metadata

Dim sProduct As String
Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer

Const cstMaxInfo = 40
ReDim _ColumnTypes(0 To cstMaxInfo)
ReDim _ColumnTypeNames(0 To cstMaxInfo)
ReDim _ColumnPrecisions(0 To cstMaxInfo)
Const cstHSQLDB1 = "HSQL Database Engine 1."
Const cstHSQLDB2 = "HSQL Database Engine 2."
Const cstFirebird = "sdbc:embedded:firebird"
Const cstMSAccess2003 = "MS Jet 0"
Const cstMSAccess2007 = "MS Jet 04."
Const cstMYSQL = "MySQL"
Const cstPOSTGRES = "PostgreSQL"
Const cstSQLITE = "SQLite"

With com.sun.star.sdbc.DataType
_ColumnTypesReference = Array( _
.ARRAY _
, .BIGINT _
, .BINARY _
, .BIT _
, .BLOB _
, .BOOLEAN _
, .CHAR _
, .CLOB _
, .DATE _
, .DECIMAL _
, .DISTINCT _
, .DOUBLE _
, .FLOAT _
, .INTEGER _
, .LONGVARBINARY _
, .LONGVARCHAR _
, .NUMERIC _
, .OBJECT _
, .OTHER _
, .REAL _
, .REF _
, .SMALLINT _
, .SQLNULL _
, .STRUCT _
, .TIME _
, .TIMESTAMP _
, .TINYINT _
, .VARBINARY _
, .VARCHAR _
)
End With

With Metadata
sProduct = .getDatabaseProductName() & " " & .getDatabaseProductVersion
Select Case True
Case Len(sProduct) > Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1
_RDBMS = DBMS_HSQLDB1
_ColumnTypesAlias = Array(0, -5, -2, 16, -4, 16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, 12)
_BinaryStream = True
Case Len(sProduct) > Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2
_RDBMS = DBMS_HSQLDB2
_ColumnTypesAlias = Array(0, -5, -3, -7, 2004, 16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3, 12)
_BinaryStream = True
Case .URL = cstFirebird
_RDBMS = DBMS_FIREBIRD
_ColumnTypesAlias = Array(0, -5, 2004, 16, 2004, 16, 1, 12, 91, 8, 0, 8, 6, 4, 2004, 12, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, 4, 2004, 12)
_BinaryStream = True
Case Len(sProduct) > Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007
_RDBMS = DBMS_MSACCESS2007
_ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
_BinaryStream = True
Case Len(sProduct) > Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003
_RDBMS = DBMS_MSACCESS2003
_ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
_BinaryStream = True
Case Len(sProduct) > Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL
_RDBMS = DBMS_MYSQL
_ColumnTypesAlias = Array(0, -5, -2, -7, -4, -7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, -1)
_BinaryStream = False
Case Len(sProduct) > Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES
_RDBMS = DBMS_POSTGRES
_ColumnTypesAlias = Array(0, -5, -3, 16, -3, 16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12)
_BinaryStream = True
Case Len(sProduct) > Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE
_RDBMS = DBMS_SQLITE
_ColumnTypesAlias = Array(0, -5, -4, -7, -4, -7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4, 12)
_BinaryStream = True
Case Else
_RDBMS = DBMS_UNKNOWN
_BinaryStream = True
End Select

iInfo = -1
Set oTypeInfo = MetaData.getTypeInfo()
With oTypeInfo
.next()
Do While Not .isAfterLast() And iInfo < cstMaxInfo
sName = .getString(1)
lType = .getLong(2)
If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) <> "_" Or lType <> -1) Then ' Skip
Else
iInfo = iInfo + 1
_ColumnTypeNames(iInfo) = sName
_ColumnTypes(iInfo) = lType
_ColumnPrecisions(iInfo) = CLng(.getLong(3))
End If
.next()
Loop
End With
ReDim Preserve _ColumnTypes(0 To iInfo)
ReDim Preserve _ColumnTypeNames(0 To iInfo)
ReDim Preserve _ColumnPrecisions(0 To iInfo)
End With

End Sub ' _LoadMetadata V1.6.0
Access2BaseDev Database _OutputBinaryToHTML Basic _OutputDataToHTML (Procedure) 7
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputBinaryToHTML() As String
' Converts Binary value to HTML compatible string

_OutputBinaryToHTML = " "

End Function ' _OutputBinaryToHTML V1.4.0
Access2BaseDev Database _OutputBooleanToHTML Basic _OutputDataToHTML (Procedure) 7
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
' Converts input boolean value to HTML compatible string

_OutputBooleanToHTML = Iif(pbBool, "&#x2714;", "&#x2716;") ' ✔ and ✖

End Function ' _OutputBooleanToHTML V1.4.0
Access2BaseDev Database _OutputClassToHTML Basic _OutputDataToHTML (Procedure) 13
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputClassToHTML(ByVal pvArray As variant) As String
' Formats classes attribute of <tr> and <td> tags

If Not IsArray(pvArray) Then
_OutputClassToHTML = ""
ElseIf UBound(pvArray) < LBound(pvArray) Then
_OutputClassToHTML = ""
Else
_OutputClassToHTML = " class=""" & Join(pvArray, " ") & """"
End If

End Function ' _OutputClassToHTML V1.4.0
Access2BaseDev Database _OutputDataToHTML Basic _OutputToHTML (Procedure) 126
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _
, ByRef Optional pvHeaders As Variant _
, ByRef Optional pvData As Variant _
) As Boolean
' Write html tags around data found in pvTable
' Exit when error without execution stop (to avoid file remaining open ...)

Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer
Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant
Dim bDataArray As Boolean, sHeader As String
Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer
Const cstMaxRows = 200
On Local Error GoTo Error_Function

bDataArray = IsNull(pvTable)
Print #piFile, " <table class=""dbdatatable"">"
Print #piFile, " <caption>" & pvName & "</caption>"

vFieldsBin() = Array()
If bDataArray Then
Set oTableRS = Nothing
iNumFields = UBound(pvHeaders) + 1
ReDim vFieldsBin(0 To iNumFields - 1)
For i = 0 To iNumFields - 1
vFieldsBin(i) = False
Next i
Else
Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly)
iNumFields = oTableRS.Fields.Count
ReDim vFieldsBin(0 To iNumFields - 1)
With com.sun.star.sdbc.DataType
For i = 0 To iNumFields - 1
iDataType = oTableRS.Fields(i).DataType
vFieldsBin(i) = Utils._IsBinaryType(iDataType)
Next i
End With
End If

With oTableRS
Print #piFile, " <thead>"
Print #piFile, " <tr>"
For i = 0 To iNumFields - 1
If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name
Print #piFile, " <th scope=""col"">" & sHeader & "</th>"
Next i
Print #piFile, " </tr>"
Print #piFile, " </thead>"
Print #piFile, " <tfoot>"
Print #piFile, " </tfoot>"

Print #piFile, " <tbody>"
If bDataArray Then
iLastRow = UBound(pvData, 2) + 1
Else
.MoveLast
iLastRow = .RecordCount
.MoveFirst
End If
iCountRows = 0
Do While iCountRows < iLastRow
If bDataArray Then
iNumRows = iLastRow
Else
vData() = .GetRows(cstMaxRows)
iNumRows = UBound(vData, 2) + 1
End If
For j = 0 To iNumRows - 1
iCountRows = iCountRows + 1
vTrClass() = Array()
If iCountRows = 1 Then vTrClass() = _AddArray(vTrClass, "firstrow")
If iCountRows = iLastRow Then vTrClass() = _AddArray(vTrClass, "lastrow")
If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, "even") Else vTrClass() = _AddArray(vTrClass, "odd")
Print #piFile, " <tr" & _OutputClassToHTML(vTrClass) & ">"
For i = 0 To iNumFields - 1
vTdClass() = Array()
If i = 0 Then vTdClass() = _AddArray(vTdClass, "firstcol")
If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, "lastcol")
If Not vFieldsBin(i) Then
If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j)
If vDataCell Is Nothing Then vDataCell = Null ' Necessary because Null object has not a VarType = vbNull
If IsDate(vDataCell) And VarType(vDataCell) = vbString Then vDataCell = CDate(vDataCell)
Select Case VarType(vDataCell)
Case vbEmpty, vbNull
vTdClass() = _AddArray(vTdClass, "null")
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNullToHTML() & "</td>"
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt
vTdClass() = _AddArray(vTdClass, "numeric")
If vDataCell < 0 Then vTdClass() = _AddArray(vTdClass, "negative")
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNumberToHTML(vDataCell) & "</td>"
Case vbBoolean
vTdClass() = _AddArray(vTdClass, "bool")
If vDataCell = False Then vTdClass() = _AddArray(vTdClass, "false")
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBooleanToHTML(vDataCell) & "</td>"
Case vbDate
vTdClass() = _AddArray(vTdClass, "date")
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputDateToHTML(vDataCell) & "</td>"
Case vbString
vTdClass() = _AddArray(vTdClass, "char")
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputStringToHTML(vDataCell) & "</td>"
Case Else
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _CStr(vDataCell) & "</td>"
End Select
Else ' Binary fields
Print #piFile, " <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBinaryToHTML() & "</td>"
End If
Next i
Print #piFile, " </tr>"
Next j
Loop

If Not bDataArray Then .mClose()
End With
Set oTableRS = Nothing

Print #piFile, " </tbody>"
Print #piFile, " </table>"
_OutputDataToHTML = True

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEWARNING, Err, "_OutputDataToHTML", Erl)
_OutputDataToHTML = False
Resume Exit_Function
End Function ' _OutputDataToHTML V1.4.0
Access2BaseDev Database _OutputDateToHTML Basic _OutputDataToHTML (Procedure) 7
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputDateToHTML(ByVal psDate As Date) As String
' Converts input date to HTML compatible string

_OutputDateToHTML = Format(psDate) ' With regional settings - Ignores time if = to 0

End Function ' _OutputDateToHTML V1.4.0
Access2BaseDev Database _OutputNullToHTML Basic _OutputDataToHTML (Procedure) 7
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputNullToHTML() As String
' Converts Null value to HTML compatible string

_OutputNullToHTML = " "

End Function ' _OutputNullToHTML V1.4.0
Access2BaseDev Database _OutputNumberToHTML Basic _OutputDataToHTML (Procedure) 14
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String
' Converts input number to HTML compatible string

Dim vNumber As Variant
If IsMissing(piPrecision) Then piPrecision = -1
If pvNumber = Int(pvNumber) Then
vNumber = Int(pvNumber)
Else
If piPrecision >= 0 Then vNumber = (Int(pvNumber * 10 ^ piPrecision + 0.5)) / 10 ^ piPrecision Else vNumber = pvNumber
End If
_OutputNumberToHTML = Format(vNumber)

End Function ' _OutputNumberToHTML V1.4.0
Access2BaseDev Database _OutputStringToHTML Basic _OutputDataToHTML (Procedure) 90
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputStringToHTML(ByVal psString As String) As String
' Converts input string to HTML compatible string
' - UTF-8 encoding
' - recognition of next patterns
' - " - & - ' - < - >
' -

' - <a href="...
' -

' - <img src="...
' - , ,

Dim vPatterns As Variant
Dim lCurrentChar as Long, lPattern As Long, lNextPattern As Long, sPattern As String
Dim sOutput As String, sChar As String
Dim sUrl As String, lNextQuote As Long, lUrl As Long, bQuote As Boolean, bTagEnd As Boolean
Dim i As Integer, l As Long

vPatterns = Array( _
""", "&", "'", "<", ">", " " _
, "
", "
"
, "
"
_
, "<a href=""", "<a id=""", "", "<img src=""" _
, "<span class=""", "" _
, "", "", "", "", "", "" _
)

lCurrentChar = 1
sOutput = ""

Do While lCurrentChar <= Len(psString)
' Where is next closest pattern ?
lPattern = Len(psString) + 1
sPattern = ""
For i = 0 To UBound(vPatterns)
lNextPattern = InStr(lCurrentChar, psString, vPatterns(i), 1) ' Text (not case-sensitive) string comparison
If lNextPattern > 0 And lNextPattern < lPattern Then
lPattern = lNextPattern
sPattern = Mid(psString, lPattern, Len(vPatterns(i)))
End If
Next i
' Up to the next pattern or to the end of the string, UTF8-encode each character
For l = lCurrentChar To lPattern - 1
sChar = Mid(psString, l, 1)
sOutput = sOutput & Utils._UTF8Encode(sChar)
Next l
' Process hyperlink patterns and keep others
If Len(sPattern) > 0 Then
Select Case LCase(sPattern)
Case "<a href=""", "<a id=""", "<img src=""", "<span class="""
' Up to next quote, url-encode
lNextQuote = 0
lUrl = lPattern + Len(sPattern)
lNextQuote = InStr(lUrl, psString, """", 1)
If lNextQuote = 0 Then lNextQuote = Len(psString) ' Should not happen but, if quoted string not closed ...
sUrl = Mid(psString, lUrl, lNextQuote - lUrl)
sOutput = sOutput & sPattern & sUrl & """"
lCurrentChar = lNextQuote + 1
bQuote = False
bTagEnd = False
Do
sChar = Mid(psString, lCurrentChar, 1)
Select Case sChar
Case """"
bQuote = Not bQuote
sOutput = sOutput & sChar
Case ">" ' Tag end if not somewhere between quotes
If Not bQuote Then
bTagEnd = True
sOutput = sOutput & sChar
Else
sOutput = sOutput & _UTF8Encode(sChar)
End If
Case Else
sOutput = sOutput & _UTF8Encode(sChar)
End Select
lCurrentChar = lCurrentChar + 1
If lCurrentChar > Len(psString) Then bTagEnd = True ' Should not happen but, if tag not closed ...
Loop Until bTagEnd
Case Else
sOutput = sOutput & sPattern
lCurrentChar = lPattern + Len(sPattern)
End Select
Else
lCurrentChar = Len(psString) + 1
End If
Loop

_OutputStringToHTML = sOutput

End Function ' _OutputStringToHTML V1.4.0
Access2BaseDev Database _OutputToCalc Basic OutputTo (Procedure) 79
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputToCalc(poData As Object _
, ByVal psOutputFile As String _
, ByVal psFilter As String _
, Optional ByVal plEncoding As Long _
) As Boolean
' https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Database_Import
' https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options

Dim oCalcDoc As Object, oSheet As Object, vWin As Variant
Dim vImportDesc() As Variant, iSource As Integer
Dim oRange As Object, i As Integer, iCol As Integer, oColumns As Object

If _ErrorHandler() Then On Local Error Goto Error_Function
_OutputToCalc = False
If IsMissing(plEncoding) Then plEncoding = acUTF8Encoding
' Create a new OO-Calc-Document
Set oCalcDoc = StarDesktop.LoadComponentFromURL( _
"private:factory/scalc" _
, "_default" ,0, Array() _
)

' Get the unique spreadsheet
Set oSheet = oCalcDoc.Sheets(0)

' Describe import
With poData
If ._Type = "TABLEDEF" Then
iSource = com.sun.star.sheet.DataImportMode.TABLE
Else
iSource = com.sun.star.sheet.DataImportMode.QUERY
End If
vImportDesc = Array( _
_MakePropertyValue("DatabaseName", URL) _
, _MakePropertyValue("SourceType", iSource) _
, _MakePropertyValue("SourceObject", ._Name) _
)
oSheet.Name = ._Name
End With

' Import
oSheet.getCellByPosition(0, 0).doImport(vImportDesc())

Select Case psFilter
Case acFormatODS, acFormatXLS, acFormatXLSX ' Formatting
iCol = poData.Fields().Count
Set oRange = oSheet.getCellRangeByPosition(0, 0, iCol - 1, 0)
oRange.CharWeight = com.sun.star.awt.FontWeight.BOLD
oRange.CellBackColor = RGB(200, 200, 200)
oRange.HoriJustify = com.sun.star.table.CellHoriJustify.CENTER
Set oColumns = oRange.getColumns()
For i = 0 To iCol - 1
oColumns.getByIndex(i).OptimalWidth = True
Next i
oCalcDoc.storeAsUrl(psOutputFile, Array( _
_MakePropertyValue("FilterName", psFilter) _
, _MakePropertyValue("Overwrite", True) _
))
Case Else
oCalcDoc.storeAsUrl(psOutputFile, Array( _
_MakePropertyValue("FilterName", psFilter) _
, _MakePropertyValue("FilterOptions", _FilterOptionsDefault(plEncoding)) _
, _MakePropertyValue("Overwrite", True) _
))
End Select

oCalcDoc.close(False)
_OutputToCalc = True

Exit_Function:
Set oColumns = Nothing
Set oRange = Nothing
Set oSheet = Nothing
Set oCalcDoc = Nothing
Exit Function
Error_Function:
TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
Goto Exit_Function
End Function ' OutputToCalc V1.4.0
Access2BaseDev Database _OutputToHTML Basic OutputTo (Procedure) 65
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _OutputToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal psOutputFile As String, ByVal psTemplateFile As String _
, ByRef Optional pvHeaders As Variant _
, ByRef Optional pvData As Variant _
) As Boolean
' http://www.ehow.com/how_5652706_create-html-template-ms-access.html

Dim bDataArray As Boolean
Dim vMinimalTemplate As Variant, vTemplate As Variant
Dim iFile As Integer, i As Integer, sLine As String, lBody As Long
Const cstTitle = "<!--Template_Title-->", cstBody = "<!--Template_Body-->"
Const cstTitleAlt = "<!--AccessTemplate_Title-->", cstBodyAlt = "<!--AccessTemplate_Body-->"

On Local Error GoTo Error_Function
vMinimalTemplate = Array( _
"<!DOCTYPE html>" _
, "<html>" _
, " <head>" _
, " <title>" & cstTitle & "</title>" _
, " </head>" _
, " <body>" _
, " " & cstBody _
, " </body>" _
, "</html>" _
)

vTemplate = _ReadFileIntoArray(psTemplateFile)
If LBound(vTemplate) > UBound(vTemplate) Then vTemplate() = vMinimalTemplate()

bDataArray = IsNull(pvTable)

' Write output file
iFile = FreeFile()
Open psOutputFile For Output Access Write Lock Read Write As #iFile
For i = 0 To UBound(vTemplate)
sLine = vTemplate(i)
sLine = Join(Split(sLine, cstTitleAlt), cstTitle)
sLine = Join(Split(sLine, cstBodyAlt), cstBody)
Select Case True
Case InStr(sLine, cstTitle) > 0
sLine = Join(Split(sLine, cstTitle), pvName)
Print #iFile, sLine
Case InStr(sLine, cstBody) > 0
lBody = InStr(sLine, cstBody)
If lBody > 1 Then Print #iFile, Left(sLine, lBody - 1)
If bDataArray Then
_OutputDataToHTML(pvTable, pvName, iFile, pvHeaders, pvData)
Else
_OutputDataToHTML(pvTable, pvName, iFile)
End If
If Len(sLine) > lBody + Len(cstBody) - 1 Then Print #iFile, Right(sLine, Len(sLine) - lBody + Len(cstBody) + 1)
Case Else
Print #iFile, sLine
End Select
Next i
Close #iFile

_OutputToHTML = True

Exit_Function:
Exit Function
Error_Function:
_OutputToHTML = False
GoTo Exit_Function
End Function ' _OutputToHTML V1.4.0
Access2BaseDev Database _PropertiesList Basic hasProperty (Procedure)
Properties (Procedure)
13
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

_PropertiesList = Array("Connect", "Name", "ObjectType" _
, "OnCreate", "OnFocus", "OnLoad", "OnLoadFinished", "OnModifyChanged" _
, "OnNew", "OnPrepareUnload", "OnPrepareViewClosing", "OnSave", "OnSaveAs" _
, "OnSaveAsDone", "OnSaveAsFailed", "OnSaveDone", "OnSaveFailed", "OnSaveTo" _
, "OnSaveToDone", "OnSaveToFailed", "OnSubComponentClosed", "OnSubComponentOpened" _
, "OnTitleChanged", "OnUnfocus", "OnUnload", "OnViewClosed", "OnViewCreated" _
, "Version" _
)

End Function ' _PropertiesList
Access2BaseDev Database _PropertyGet Basic Connect (Procedure)
Name (Procedure)
ObjectType (Procedure)
OnCreate (Procedure)
OnFocus (Procedure)
OnLoad (Procedure)
OnLoadFinished (Procedure)
OnModifyChanged (Procedure)
OnNew (Procedure)
OnPrepareUnload (Procedure)
OnPrepareViewClosing (Procedure)
OnSave (Procedure)
OnSaveAs (Procedure)
OnSaveAsDone (Procedure)
OnSaveAsFailed (Procedure)
OnSaveDone (Procedure)
OnSaveFailed (Procedure)
OnSubComponentClosed (Procedure)
OnSubComponentOpened (Procedure)
OnTitleChanged (Procedure)
OnUnfocus (Procedure)
OnUnload (Procedure)
OnViewClosed (Procedure)
OnViewCreated (Procedure)
Version (Procedure)
getProperty (Procedure)
Properties (Procedure)
63
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

Dim i As Integer, vEvents As Variant, sEvent As String, vEvent As Variant

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Database.get" & psProperty)

_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("Connect")
_PropertyGet = Document.Datasource.URL
' Location = ConvertFromUrl(URL)
Case UCase("Name")
_PropertyGet = Title
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("OnCreate"), UCase("OnFocus"), UCase("OnLoad"), UCase("OnLoadFinished"), UCase("OnModifyChanged") _
, UCase("OnNew"), UCase("OnPrepareUnload"), UCase("OnPrepareViewClosing"), UCase("OnSave"), UCase("OnSaveAs") _
, UCase("OnSaveAsDone"), UCase("OnSaveAsFailed"), UCase("OnSaveDone"), UCase("OnSaveFailed"), UCase("OnSaveTo") _
, UCase("OnSaveToDone"), UCase("OnSaveToFailed"), UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") _
, UCase("OnTitleChanged"), UCase("OnUnfocus"), UCase("OnUnload"), UCase("OnViewClosed"), UCase("OnViewCreated")
' Find script event
sEvent = ""
vEvents = Document.getEvents().ElementNames ' Returns an array
For i = 0 To UBound(vEvents)
If UCase(vEvents(i)) = UCase(psProperty) Then
sEvent = vEvents(i)
Exit For
End If
Next i
If sEvent = "" Then
_PropertyGet = ""
Else
vEvent = Document.getEvents().getByName(sEvent)
If IsEmpty(vEvent) Then
_PropertyGet = ""
ElseIf vEvent(0).Value <> "Script" Then
_PropertyGet = ""
Else
_PropertyGet = vEvent(1).Value
End If
End If
Case UCase("Version")
_PropertyGet = MetaData.getDatabaseProductName() & " " & MetaData.getDatabaseProductVersion
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Database.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Database._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Database _ReplaceSquareBrackets Basic CreateQueryDef (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
RunSQL (Procedure)
_DFunction (Procedure)
25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String
' Returns psSql after substitution of [] by quote character
' [] square brackets in (single) quoted strings not affected

Dim sQuote As String 'RDBMS specific quote character
Dim vSubStrings() As Variant, i As Integer
Const cstSingleQuote = "'"

sQuote = MetaData.IdentifierQuoteString
If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported.
_ReplaceSquareBrackets = Trim(psSql)
Exit Function
End If
vSubStrings() = Split(psSql, cstSingleQuote)
For i = 0 To UBound(vSubStrings)
If (i Mod 2) = 0 Or (i = UBound(vSubStrings)) Then ' Only even substrings are parsed for square brackets. Last substring is parsed anyway
vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote)
vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote)
End If
Next i

_ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote))

End Function ' ReplaceSquareBrackets V1.1.0
Access2BaseDev Database Class_Initialize Basic Class_Terminate (Procedure) 25
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJDATABASE
Set _This = Nothing
_DbConnect = 0
Title = ""
Set Document = Nothing
Set Connection = Nothing
URL = ""
_ReadOnly = False
Set MetaData = Nothing
_RDBMS = DBMS_UNKNOWN
_ColumnTypes = Array()
_ColumnTypeNames = Array()
_ColumnPrecisions = Array()
_ColumnTypesReference = Array()
_ColumnTypesAlias() = Array()
_BinaryStream = False
Set Form = Nothing
FormName = ""
RecordsetMax = 0
Set RecordsetsColl = New Collection
End Sub ' Constructor
Access2BaseDev Database Class_Terminate Basic Dispose (Procedure) 15
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call CloseAllRecordsets()
If _DbConnect <> DBCONNECTANY Then
If Not IsNull(Connection) Then
Connection.close()
Connection.dispose()
Set Connection = Nothing
End If
Else
mClose()
End If
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Database CloseAllRecordsets Basic Class_Terminate (Procedure) 19
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub CloseAllRecordsets()
' Clean all recordsets for housekeeping

Dim sRecordsets() As String, i As Integer, oRecordset As Object
On Local Error Goto Exit_Sub

If IsNull(RecordsetsColl) Then Exit Sub
If RecordsetsColl.Count < 1 Then Exit Sub
For i = 1 To RecordsetsColl.Count
Set oRecordset = RecordsetsColl.Item(i)
oRecordset.mClose(False) ' Do not remove entry in collection
Next i
Set RecordsetsColl = New Collection
RecordsetMax = 0

Exit_Sub:
Exit Sub
End Sub ' CloseAllRecordsets V0.9.5
Access2BaseDev Database Connect Basic   3
Property Get Connect() As String
Connect = _PropertyGet("Connect")
End Property ' Connect (get)
Access2BaseDev Database CreateQueryDef Basic   60
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _
, ByVal Optional pvSql As Variant _
, ByVal Optional pvOption As Variant _
) As Object
'Return a (new) QueryDef object based on SQL statement
Const cstThisSub = "Database.CreateQueryDef"
Utils._SetCalledSub(cstThisSub)

Const cstNull = -1
Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String

If _ErrorHandler() Then On Local Error Goto Error_Function

Set CreateQueryDef = Nothing
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
If IsMissing(pvQueryName) Then Call _TraceArguments()
If IsMissing(pvSql) Then Call _TraceArguments()
If IsMissing(pvOption) Then pvOption = cstNull

If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function
If pvQueryName = "" Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function
If pvSql = "" Then Call _TraceArguments()
If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function

If _ReadOnly Then Goto Error_NoUpdate

Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition")
oQuery.rename(pvQueryName)
oQuery.Command = _ReplaceSquareBrackets(pvSql)
oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )

Set oQueries = Document.DataSource.getQueryDefinitions()
With oQueries
For i = 0 To .getCount() - 1
sQueryName = .getByIndex(i).Name
If UCase(sQueryName) = UCase(pvQueryName) Then
TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName)
.removeByName(sQueryName)
Exit For
End If
Next i
.insertByName(pvQueryName, oQuery)
End With
Set CreateQueryDef = QueryDefs(pvQueryName)

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' CreateQueryDef V1.1.0
Access2BaseDev Database CreateTableDef Basic   64
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object
'Return a (new/empty) TableDef object
Const cstThisSub = "Database.CreateTableDef"
Utils._SetCalledSub(cstThisSub)

Dim oTable As Object, oTables As Object, sTables() As String
Dim i As Integer, sTableName As String, oNewTable As Object
Dim vNameComponents() As Variant, iNames As Integer

If _ErrorHandler() Then On Local Error Goto Error_Function

Set CreateTableDef = Nothing
If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
If IsMissing(pvTableName) Then Call _TraceArguments()

If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function
If pvTableName = "" Then Call _TraceArguments()

If _ReadOnly Then Goto Error_NoUpdate

Set oTables = Connection.getTables
With oTables
sTables = .ElementNames()
' Check existence of object and find its exact (case-sensitive) name
For i = 0 To UBound(sTables)
If UCase(pvTableName) = UCase(sTables(i)) Then
sTableName = sTables(i)
TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName)
.dropByName(sTableName)
Exit For
End If
Next i
Set oNewTable = New DataDef
oNewTable._Type = OBJTABLEDEF
oNewTable._Name = pvTableName
vNameComponents = Split(pvTableName, ".")
iNames = UBound(vNameComponents)
If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = ""
If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = ""
oNewtable.TableName = vNameComponents(iNames)
Set oNewTable._ParentDatabase = _This
Set oNewTable.TableDescriptor = .createDataDescriptor()
oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName
oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName
oNewTable.TableDescriptor.Name = oNewTable.TableName
oNewTable.TableDescriptor.Type = "TABLE"
End With

Set CreateTabledef = oNewTable

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' CreateTableDef V1.1.0
Access2BaseDev Database DAvg Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DAvg( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return average of scope
Const cstThisSub = "Database.DAvg"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DAvg
Access2BaseDev Database DCount Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DCount( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return # of occurrences of scope
Const cstThisSub = "Database.DCount"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DCount
Access2BaseDev Database Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Database DLookup Basic   30
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DLookup( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
, ByVal Optional pvOrderClause As Variant _
) As Variant

' Return a value within a table
'Arguments: psExpr: an SQL expression
' psDomain: a table- or queryname
' pvCriteria: an optional WHERE clause
' pcOrderClause: an optional order clause incl. "DESC" if relevant
'Return: Value of the psExpr if found, else Null.
'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html
'Examples:
' 1. To find the last value, include DESC in the OrderClause, e.g.:
' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
' 2. To find the lowest non-null value of a field, use the Criteria, e.g.:
' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")

Const cstThisSub = "Database.DLookup"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DLookup = _DFunction("", psExpr, psDomain _
, Iif(IsMissing(pvCriteria), "", pvCriteria) _
, Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
)
Utils._ResetCalledSub(cstThisSub)
End Function ' DLookup
Access2BaseDev Database DMax Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DMax( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return maximum of scope
Const cstThisSub = "Database.DMax"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DMax
Access2BaseDev Database DMin Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DMin( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return minimum of scope
Const cstThisSub = "Database.DMin"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DMin
Access2BaseDev Database DStDev Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DStDev( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return standard deviation of scope
Const cstThisSub = "Database.DStDev"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
Utils._ResetCalledSub(cstThisSub)
End Function ' DStDev
Access2BaseDev Database DStDevP Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DStDevP( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return standard deviation of scope
Const cstThisSub = "Database.DStDevP"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
Utils._ResetCalledSub(cstThisSub)
End Function ' DStDevP
Access2BaseDev Database DSum Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DSum( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return sum of scope
Const cstThisSub = "Database.DSum"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DSum
Access2BaseDev Database DVar Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DVar( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return variance of scope
Const cstThisSub = "Database.DVar"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DVar
Access2BaseDev Database DVarP Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function DVarP( _
ByVal Optional psExpr As String _
, ByVal Optional psDomain As String _
, ByVal Optional pvCriteria As Variant _
) As Variant
' Return variance of scope
Const cstThisSub = "Database.DVarP"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DVarP
Access2BaseDev Database getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("Database.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Database.getProperty")

End Function ' getProperty
Access2BaseDev Database hasProperty Basic   8
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
Access2BaseDev Database mClose Basic Class_Terminate (Procedure) 25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function mClose() As Variant
' Close the database

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Database.Close"
Utils._SetCalledSub(cstThisSub)
mClose = False
If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable

Connection.close()
Connection.dispose()
Set Connection = Nothing
mClose = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
GoTo Exit_Function
End Function ' (m)Close
Access2BaseDev Database Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Database ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Database OnCreate Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnCreate() As String
OnCreate = _PropertyGet("OnCreate")
End Property ' OnCreate (get)
Access2BaseDev Database OnFocus Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnFocus() As String
OnFocus = _PropertyGet("OnFocus")
End Property ' OnFocus (get)
Access2BaseDev Database OnLoad Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnLoad() As String
OnLoad = _PropertyGet("OnLoad")
End Property ' OnLoad (get)
Access2BaseDev Database OnLoadFinished Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnLoadFinished() As String
OnLoadFinished = _PropertyGet("OnLoadFinished")
End Property ' OnLoadFinished (get)
Access2BaseDev Database OnModifyChanged Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnModifyChanged() As String
OnModifyChanged = _PropertyGet("OnModifyChanged")
End Property ' OnModifyChanged (get)
Access2BaseDev Database OnNew Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnNew() As String
OnNew = _PropertyGet("OnNew")
End Property ' OnNew (get)
Access2BaseDev Database OnPrepareUnload Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnPrepareUnload() As String
OnPrepareUnload = _PropertyGet("OnPrepareUnload")
End Property ' OnPrepareUnload (get)
Access2BaseDev Database OnPrepareViewClosing Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnPrepareViewClosing() As String
OnPrepareViewClosing = _PropertyGet("OnPrepareViewClosing")
End Property ' OnPrepareViewClosing (get)
Access2BaseDev Database OnSave Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSave() As String
OnSave = _PropertyGet("OnSave")
End Property ' OnSave (get)
Access2BaseDev Database OnSaveAs Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveAs() As String
OnSaveAs = _PropertyGet("OnSaveAs")
End Property ' OnSaveAs (get)
Access2BaseDev Database OnSaveAsDone Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveAsDone() As String
OnSaveAsDone = _PropertyGet("OnSaveAsDone")
End Property ' OnSaveAsDone (get)
Access2BaseDev Database OnSaveAsFailed Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveAsFailed() As String
OnSaveAsFailed = _PropertyGet("OnSaveAsFailed")
End Property ' OnSaveAsFailed (get)
Access2BaseDev Database OnSaveDone Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveDone() As String
OnSaveDone = _PropertyGet("OnSaveDone")
End Property ' OnSaveDone (get)
Access2BaseDev Database OnSaveFailed Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveFailed() As String
OnSaveFailed = _PropertyGet("OnSaveFailed")
End Property ' OnSaveFailed (get)
Access2BaseDev Database OnSubComponentClosed Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSubComponentClosed() As String
OnSubComponentClosed = _PropertyGet("OnSubComponentClosed")
End Property ' OnSubComponentClosed (get)
Access2BaseDev Database OnSubComponentOpened Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSubComponentOpened() As String
OnSubComponentOpened = _PropertyGet("OnSubComponentOpened")
End Property ' OnSubComponentOpened (get)
Access2BaseDev Database OnTitleChanged Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnTitleChanged() As String
OnTitleChanged = _PropertyGet("OnTitleChanged")
End Property ' OnTitleChanged (get)
Access2BaseDev Database OnUnfocus Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnfocus() As String
OnUnfocus = _PropertyGet("OnUnfocus")
End Property ' OnUnfocus (get)
Access2BaseDev Database OnUnload Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnload() As String
OnUnload = _PropertyGet("OnUnload")
End Property ' OnUnload (get)
Access2BaseDev Database OnViewClosed Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnViewClosed() As String
OnViewClosed = _PropertyGet("OnViewClosed")
End Property ' OnViewClosed (get)
Access2BaseDev Database OnViewCreated Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnViewCreated() As String
OnViewCreated = _PropertyGet("OnViewCreated")
End Property ' OnViewCreated (get)
Access2BaseDev Database OpenRecordset Basic   103
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenRecordset(ByVal Optional pvSource As Variant _
, ByVal Optional pvType As Variant _
, ByVal Optional pvOptions As Variant _
, ByVal Optional pvLockEdit As Variant _
) As Object
'Return a Recordset object based on Source (= SQL, table or query name)

Const cstThisSub = "Database.OpenRecordset"
Utils._SetCalledSub(cstThisSub)
Const cstNull = -1

Dim lCommandType As Long, sCommand As String, oObject As Object
Dim sSource As String, i As Integer, iCount As Integer
Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object

If _ErrorHandler() Then On Local Error Goto Error_Function
Set oObject = Nothing
If IsMissing(pvSource) Then Call _TraceArguments()
If pvSource = "" Then Call _TraceArguments()
If IsMissing(pvType) Then
pvType = cstNull
Else
If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), dbOpenForwardOnly) Then Goto Exit_Function
End If
If IsMissing(pvOptions) Then
pvOptions = cstNull
Else
If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
End If
If IsMissing(pvLockEdit) Then
pvLockEdit = cstNull
Else
If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), dbReadOnly) Then Goto Exit_Function
End If

sSource = Split(UCase(Trim(pvSource)), " ")(0)
Select Case True
Case sSource = "SELECT"
lCommandType = com.sun.star.sdb.CommandType.COMMAND
sCommand = _ReplaceSquareBrackets(pvSource)
Case Else
sSource = UCase(Trim(pvSource))
REM Explore tables
Set oTables = Connection.getTables
sObjects = oTables.ElementNames()
bFound = False
For i = 0 To UBound(sObjects)
If sSource = UCase(sObjects(i)) Then
sCommand = sObjects(i)
bFound = True
Exit For
End If
Next i
If bFound Then
lCommandType = com.sun.star.sdb.CommandType.TABLE
Else
REM Explore queries
Set oQueries = Connection.getQueries
sObjects = oQueries.ElementNames()
For i = 0 To UBound(sObjects)
If sSource = UCase(sObjects(i)) Then
sCommand = sObjects(i)
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound
lCommandType = com.sun.star.sdb.CommandType.QUERY
End If
End Select

Set oObject = New Recordset
With oObject
._CommandType = lCommandType
._Command = sCommand
._ParentName = Title
._ParentType = _Type
._ForwardOnly = ( pvType = dbOpenForwardOnly )
._PassThrough = ( pvOptions = dbSQLPassThrough )
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
Set ._This = oObject
Set ._ParentDatabase = _This
Call ._Initialize()
RecordsetMax = RecordsetMax + 1
._Name = Format(RecordsetMax, "0000000")
RecordsetsColl.Add(oObject, UCase(._Name))
End With

If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty

Exit_Function:
Set OpenRecordset = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource))
Goto Exit_Function
End Function ' OpenRecordset V1.1.0
Access2BaseDev Database OpenSQL Basic   55
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenSQL(Optional ByVal pvSQL As Variant _
, Optional ByVal pvOption As Variant _
) As Boolean
' Return True if the execution of the SQL statement was successful
' SQL must contain a SELECT query
' pvOption can force pass through mode

If _ErrorHandler() Then On Local Error Goto Error_Function

Const cstThisSub = "Database.OpenSQL"
Utils._SetCalledSub(cstThisSub)

OpenSQL = False
If IsMissing(pvSQL) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
Const cstNull = -1
If IsMissing(pvOption) Then
pvOption = cstNull
Else
If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function
End If
If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable

Dim oURL As New com.sun.star.util.URL, oDispatch As Object
Dim vArgs(8) as New com.sun.star.beans.PropertyValue

oURL.Complete = ".component:DB/DataSourceBrowser"
oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8)

vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = Connection
vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND
vArgs(2).Name = "Command" : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL)
vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True
vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False
vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False
vArgs(6).Name = "Filter" : vArgs(6).Value = ""
vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False
vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough ))

oDispatch.dispatch(oURL, vArgs)
OpenSQL = True

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenSQL", Erl)
GoTo Exit_Function
SQL_Error:
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
Goto Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' OpenSQL V1.1.0
Access2BaseDev Database OutputTo Basic   130
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OutputTo(ByVal pvObjectType As Variant _
, ByVal Optional pvObjectName As Variant _
, ByVal Optional pvOutputFormat As Variant _
, ByVal Optional pvOutputFile As Variant _
, ByVal Optional pvAutoStart As Variant _
, ByVal Optional pvTemplateFile As Variant _
, ByVal Optional pvEncoding As Variant _
, ByVal Optional pvQuality As Variant _
, ByRef Optional pvHeaders As Variant _
, ByRef Optional pvData As Variant _
) As Boolean
'Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries
'pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Database.OutputTo"
Utils._SetCalledSub(cstThisSub)

OutputTo = False

If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function
If IsMissing(pvObjectName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
If pvOutputFormat <> "" Then
If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
UCase(acFormatHTML), "HTML" _
, UCase(acFormatODS), "ODS" _
, UCase(acFormatXLS), "XLS" _
, UCase(acFormatXLSX), "XLSX" _
, UCase(acFormatTXT), "TXT", "CSV" _
, "")) _
Then Goto Exit_Function ' A 2nd time to allow case unsensitivity
End If
If IsMissing(pvOutputFile) Then pvOutputFile = ""
If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
If IsMissing(pvAutoStart) Then pvAutoStart = False
If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function
If IsMissing(pvEncoding) Then pvEncoding = 0
If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function
If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function
If pvObjectType = acOutputArray Then
If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments()
pvOutputFormat = "HTML"
End If

Dim sOutputFile As String, oTable As Object
Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String

If pvObjectType = acOutputArray Then
Set oTable = Nothing
Else
'Find applicable table or query
If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True)
If IsNull(oTable) Then Goto Error_NotFound
End If

'Determine format and parameters
If pvOutputFormat = "" Then
sOutputFormat = _PromptFormat(Array("HTML", "ODS", "XLS", "XLSX", "TXT")) ' Prompt user for format
If sOutputFormat = "" Then Goto Exit_Function
Else
sOutputFormat = UCase(pvOutputFormat)
End If

'Determine output file
If pvOutputFile = "" Then ' Prompt file picker to user
Select Case sOutputFormat
Case UCase(acFormatHTML), "HTML" : sSuffix = "html"
Case UCase(acFormatODS), "ODS" : sSuffix = "ods"
Case UCase(acFormatXLS), "XLS" : sSuffix = "xls"
Case UCase(acFormatXLSX), "XLSX" : sSuffix = "xlsx"
Case UCase(acFormatTXT), "TXT", "CSV" : sSuffix = "txt"
End Select
sOutputFile = _PromptFilePicker(sSuffix)
If sOutputFile = "" Then Goto Exit_Function
Else
sOutputFile = pvOutputFile
End If
sOutputFile = ConvertToURL(sOutputFile)

'Create file
Select Case sOutputFormat
Case UCase(acFormatHTML), "HTML"
If pvObjectType = acOutputArray Then
bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData)
Else
bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile)
End If
Case UCase(acFormatODS), "ODS"
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS)
Case UCase(acFormatXLS), "XLS"
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS)
Case UCase(acFormatXLS), "XLSX"
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX)
Case UCase(acFormatTXT), "TXT", "CSV"
bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding)
End Select

'Launch application, if requested
If bOutput Then
If pvAutoStart Then Call _ShellExecute(sOutputFile)
Else
GoTo Error_File
End If

OutputTo = True

Exit_Function:
If Not IsNull(oTable) Then
oTable.Dispose()
Set oTable = Nothing
End If
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_File:
TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
GoTo Exit_Function
End Function ' OutputTo V1.4.0
Access2BaseDev Database Properties Basic   23
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Utils._SetCalledSub("Database.Properties")
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If
Set vProperty._ParentDatabase = _This

Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub("Database.Properties")
Exit Function
End Function ' Properties
Access2BaseDev Database QueryDefs Basic CreateQueryDef (Procedure)
OutputTo (Procedure)
65
REM -----------------------------------------------------------------------------------------------------------------------
Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
' Collect all Queries in the database
' pbCheck unpublished

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Database.QueryDefs")
If IsMissing(pbCheck) Then pbCheck = False

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oQueries As Object
Set oObject = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If

Set oQueries = Connection.getQueries
sObjects = oQueries.ElementNames()
Select Case True
Case IsMissing(pvIndex)
Set oObject = New Collect
oObject._CollType = COLLQUERYDEFS
oObject._ParentType = OBJDATABASE
oObject._ParentName = ""
Set oObject._ParentDatabase = _This
oObject._Count = UBound(sObjects) + 1
Goto Exit_Function
Case VarType(pvIndex) = vbString
bFound = False
' Check existence of object and find its exact (case-sensitive) name
For i = 0 To UBound(sObjects)
If UCase(pvIndex) = UCase(sObjects(i)) Then
sObjectName = sObjects(i)
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound
Case Else ' pvIndex is numeric
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
sObjectName = sObjects(pvIndex)
End Select

Set oObject = New DataDef
oObject._Type = OBJQUERYDEF
oObject._Name = sObjectName
Set oObject._ParentDatabase = _This
oObject._readOnly = _ReadOnly
Set oObject.Query = oQueries.getByName(sObjectName)

Exit_Function:
Set QueryDefs = oObject
Set oObject = Nothing
Utils._ResetCalledSub("Database.QueryDefs")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl)
GoTo Exit_Function
Trace_NotFound:
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' QueryDefs V1.1.0
Access2BaseDev Database Recordsets Basic   47
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
' Collect all active recordsets

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Database.Recordsets")

Set Recordsets = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oTables As Object

Select Case True
Case IsMissing(pvIndex)
Set oObject = New Collect
oObject._CollType = COLLRECORDSETS
oObject._ParentType = OBJDATABASE
oObject._ParentName = ""
Set oObject._ParentDatabase = _This
oObject._Count = RecordsetsColl.Count
Case VarType(pvIndex) = vbString
bFound = _hasRecordset(pvIndex)
If Not bFound Then Goto Trace_NotFound
Set oObject = RecordsetsColl.Item(pvIndex)
Case Else ' pvIndex is numeric
If pvIndex < 0 Or pvIndex >= RecordsetsColl.Count Then Goto Trace_IndexError
Set oObject = RecordsetsColl.Item(pvIndex + 1) ' Collection members are numbered 1 ... Count
End Select

Exit_Function:
Set Recordsets = oObject
Set oObject = Nothing
Utils._ResetCalledSub("Database.Recordsets")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Database.Recordsets", Erl)
GoTo Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Recordsets V0.9.5
Access2BaseDev Database RunSQL Basic   40
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RunSQL(Optional ByVal pvSQL As Variant _
, Optional ByVal pvOption As Variant _
) As Boolean
' Return True if the execution of the SQL statement was successful
' SQL must contain an ACTION query

If _ErrorHandler() Then On Local Error Goto Error_Function

Const cstThisSub = "Database.RunSQL"
Utils._SetCalledSub(cstThisSub)

RunSQL = False
If IsMissing(pvSQL) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
Const cstNull = -1
If IsMissing(pvOption) Then
pvOption = cstNull
Else
If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
End If

Dim oStatement As Object, vResult As Variant
Set oStatement = Connection.createStatement()
oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
On Local Error Goto SQL_Error
vResult = oStatement.execute(_ReplaceSquareBrackets(pvSQL))
On Local Error Goto Error_Function
RunSQL = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
SQL_Error:
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
Goto Exit_Function
End Function ' RunSQL V1.1.0
Access2BaseDev Database TableDefs Basic OutputTo (Procedure) 71
REM -----------------------------------------------------------------------------------------------------------------------
Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
' Collect all tables in the database
' pbCheck unpublished

Const cstThisSub = "Database.TableDefs"
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
If IsMissing(pbCheck) Then pbCheck = False

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oTables As Object
Set oObject = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If

Set oTables = Connection.getTables
sObjects = oTables.ElementNames()
Select Case True
Case IsMissing(pvIndex)
Set oObject = New Collect
oObject._CollType = COLLTABLEDEFS
oObject._ParentType = OBJDATABASE
oObject._ParentName = ""
Set oObject._ParentDatabase = _This
oObject._Count = UBound(sObjects) + 1
Goto Exit_Function
Case VarType(pvIndex) = vbString
bFound = False
' Check existence of object and find its exact (case-sensitive) name
For i = 0 To UBound(sObjects)
If UCase(pvIndex) = UCase(sObjects(i)) Then
sObjectName = sObjects(i)
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound
Case Else ' pvIndex is numeric
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
sObjectName = sObjects(pvIndex)
End Select

Set oObject = New DataDef
With oObject
._Type = OBJTABLEDEF
._Name = sObjectName
Set ._ParentDatabase = _This
._ReadOnly = _ReadOnly
Set .Table = oTables.getByName(sObjectName)
.CatalogName = .Table.CatalogName
.SchemaName = .Table.SchemaName
.TableName = .Table.Name
End With

Exit_Function:
Set TableDefs = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' TableDefs V1.1.0
Access2BaseDev Database Version Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Version() As String
Version = _PropertyGet("Version")
End Property ' Version (get)
Access2BaseDev DataDef _PropertiesList Basic hasProperty (Procedure)
Properties (Procedure)
12
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

Select Case _Type
Case OBJTABLEDEF
_PropertiesList = Array("Name", "ObjectType")
Case OBJQUERYDEF
_PropertiesList = Array("Name", "ObjectType", "SQL", "Type")
Case Else
End Select

End Function ' _PropertiesList
Access2BaseDev DataDef _PropertyGet Basic Name (Procedure)
ObjectType (Procedure)
SQL (Procedure)
pType (Procedure)
getProperty (Procedure)
Properties (Procedure)
57
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type)
Utils._SetCalledSub(cstThisSub & ".get" & psProperty)
Dim sSql As String, sVerb As String, iType As Integer
_PropertyGet = EMPTY
If Not hasProperty(psProperty) Then Goto Trace_Error

Select Case UCase(psProperty)
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("SQL")
_PropertyGet = Query.Command
Case UCase("Type")
iType = 0
sSql = Utils._Trim(UCase(Query.Command))
sVerb = Split(sSql, " ")(0)
If sVerb = "SELECT" Then iType = iType + dbQSelect
If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 _
Or sVerb = "CREATE" And InStr(sSql, " TABLE ") > 0 _
Then iType = iType + dbQMakeTable
If sVerb = "SELECT" And InStr(sSql, " UNION ") > 0 Then iType = iType + dbQSetOperation
If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough
If sVerb = "INSERT" Then iType = iType + dbQAppend
If sVerb = "DELETE" Then iType = iType + dbQDelete
If sVerb = "UPDATE" Then iType = iType + dbQUpdate
If sVerb = "CREATE" _
Or sVerb = "ALTER" _
Or sVerb = "DROP" _
Or sVerb = "RENAME" _
Or sVerb = "TRUNCATE" _
Then iType = iType + dbQDDL
' dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate
' To check Type use: If (iType And dbQxxx) <> 0 Then ...
_PropertyGet = iType
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub & ".get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev DataDef _PropertySet Basic SQL (Procedure)
setProperty (Procedure)
50
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
' Return True if property setting OK

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type)
Utils._SetCalledSub(cstThisSub & ".set" & psProperty)

'Execute
Dim iArgNr As Integer

_PropertySet = True
Select Case UCase(_A2B_.CalledSub)
Case UCase("setProperty") : iArgNr = 3
Case UCase(cstThisSub & ".setProperty") : iArgNr = 2
Case UCase(cstThisSub & ".set" & psProperty) : iArgNr = 1
End Select

If Not hasProperty(psProperty) Then Goto Trace_Error

If _ReadOnly Then Goto Error_NoUpdate

Select Case UCase(psProperty)
Case UCase("SQL")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
Query.Command = pvValue
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub & ".set" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev DataDef Class_Initialize Basic Class_Terminate (Procedure) 17
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = ""
_Name = ""
Set _ParentDatabase = Nothing
_ReadOnly = False
Set Table = Nothing
CatalogName = ""
SchemaName = ""
TableName = ""
Set Query = Nothing
Set TableDescriptor = Nothing
TableFieldsCount = 0
TableKeysCount = 0
End Sub ' Constructor
Access2BaseDev DataDef Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev DataDef CreateField Basic   116
Public Function CreateField(ByVal Optional pvFieldName As Variant _
, ByVal optional pvType As Variant _
, ByVal optional pvSize As Variant _
, ByVal optional pvAttributes As variant _
) As Object
'Return a Field object
Const cstThisSub = "TableDef.CreateField"
Utils._SetCalledSub(cstThisSub)

If _ErrorHandler() Then On Local Error Goto Error_Function

Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object
Const cstMaxKeyLength = 30

CreateField = Nothing
If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
If IsMissing(pvFieldName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function
If pvFieldName = "" Then Call _TraceArguments()
If IsMissing(pvType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _
dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _
, dbNumeric, dbDecimal, dbText, dbChar, dbMemo _
, dbDate, dbTime, dbTimeStamp _
, dbBinary, dbVarBinary, dbLongBinary, dbBoolean _
)) Then Goto Exit_Function
If IsMissing(pvSize) Then pvSize = 0
If pvSize < 0 Then pvSize = 0
If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function
If IsMissing(pvAttributes) Then pvAttributes = 0
If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function

If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable
If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable

If _ReadOnly Then Goto Error_NoUpdate

Set oNewField = New Field
With oNewField
._Name = pvFieldName
._ParentName = _Name
._ParentType = OBJTABLEDEF
If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table
Set .Column = oTable.Columns.createDataDescriptor()
End With
With oNewField.Column
.Name = pvFieldName
Select Case pvType
Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT
Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER
Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT
Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT
Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL
Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE
Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC
Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL
Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR
Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR
Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR
Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE
Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME
Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP
Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY
Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY
Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY
Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN
End Select
.Precision = Int(pvSize)
If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10
.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName
If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName
If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName
If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1
If pvAttributes = dbAutoIncrField Then
If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists
Set oKeys = oTable.Keys
Set oPrimaryKey = oKeys.createDataDescriptor()
Set oColumn = oPrimaryKey.Columns.createDataDescriptor()
oColumn.Name = pvFieldName
oColumn.CatalogName = CatalogName
oColumn.SchemaName = SchemaName
oColumn.TableName = TableName
oColumn.IsAutoIncrement = True
oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oPrimaryKey.Columns.appendByDescriptor(oColumn)
oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength)
oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY
oKeys.appendByDescriptor(oPrimaryKey)
.IsAutoIncrement = True
.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oColumn.dispose()
Else
.IsAutoIncrement = False
End If
End With
oTable.Columns.appendByDescriptor(oNewfield.Column)

Set CreateField = oNewField

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Sequence:
TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName)
Goto Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' CreateField V1.1.0
Access2BaseDev DataDef Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev DataDef Execute Basic   50
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean
'Execute a stored query. The query must be an ACTION query.

Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".Execute"
Utils._SetCalledSub(cstThisSub)
On Local Error Goto Error_Function
Const cstNull = -1
Execute = False
If _Type <> OBJQUERYDEF Then Goto Trace_Method
If IsMissing(pvOptions) Then
pvOptions = cstNull
Else
If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
End If

'Check action query
Dim oStatement As Object, vResult As Variant
Dim iType As Integer, sSql As String
iType = pType
If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action

'Execute action query
Set oStatement = _ParentDatabase.Connection.createStatement()
sSql = Query.Command
If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _
Else oStatement.EscapeProcessing = Query.EscapeProcessing
On Local Error Goto SQL_Error
vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql))
On Local Error Goto Error_Function

Execute = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Method:
TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub)
Goto Exit_Function
Trace_Action:
TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name)
Goto Exit_Function
SQL_Error:
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' Execute V1.1.0
Access2BaseDev DataDef Fields Basic   65
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Fields(ByVal Optional pvIndex As variant) As Object

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".Fields"
Utils._SetCalledSub(cstThisSub)

Set Fields = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oFields As Object

If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns()
sObjects = oFields.ElementNames()
Select Case True
Case IsMissing(pvIndex)
Set oObject = New Collect
oObject._CollType = COLLFIELDS
oObject._ParentType = _Type
oObject._ParentName = _Name
Set oObject._ParentDatabase = _ParentDatabase
oObject._Count = UBound(sObjects) + 1
Goto Exit_Function
Case VarType(pvIndex) = vbString
bFound = False
' Check existence of object and find its exact (case-sensitive) name
For i = 0 To UBound(sObjects)
If UCase(pvIndex) = UCase(sObjects(i)) Then
sObjectName = sObjects(i)
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound
Case Else ' pvIndex is numeric
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
sObjectName = sObjects(pvIndex)
End Select

Set oObject = New Field
oObject._Name = sObjectName
Set oObject.Column = oFields.getByName(sObjectName)
oObject._ParentName = _Name
oObject._ParentType = _Type
Set oObject._ParentDatabase = _ParentDatabase

Exit_Function:
Set Fields = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Fields
Access2BaseDev DataDef getProperty Basic   12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".getProperty"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub(cstThisSub)

End Function ' getProperty
Access2BaseDev DataDef hasProperty Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)

Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".hasProperty"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
Utils._ResetCalledSub(cstThisSub)
Exit Function

End Function ' hasProperty
Access2BaseDev DataDef Name Basic   3
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev DataDef ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev DataDef OpenRecordset Basic   68
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object
'Return a Recordset object based on current table- or querydef object

Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".OpenRecordset"
Utils._SetCalledSub(cstThisSub)
Const cstNull = -1
Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean

Set oObject = Nothing
If IsMissing(pvType) Then
pvType = cstNull
Else
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), dbOpenForwardOnly) Then Goto Exit_Function
End If
If IsMissing(pvOptions) Then
pvOptions = cstNull
Else
If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
End If
If IsMissing(pvLockEdit) Then
pvLockEdit = cstNull
Else
If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), dbReadOnly) Then Goto Exit_Function
End If

Select Case _Type
Case OBJTABLEDEF
lCommandType = com.sun.star.sdb.CommandType.TABLE
sCommand = _Name
Case OBJQUERYDEF
lCommandType = com.sun.star.sdb.CommandType.QUERY
sCommand = _Name
If pvOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing
End Select

Set oObject = New Recordset
With oObject
._CommandType = lCommandType
._Command = sCommand
._ParentName = _Name
._ParentType = _Type
._ForwardOnly = ( pvType = dbOpenForwardOnly )
._PassThrough = bPassThrough
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
Set ._ParentDatabase = _ParentDatabase
Set ._This = oObject
Call ._Initialize()
End With
With _ParentDatabase
.RecordsetMax = .RecordsetMax + 1
oObject._Name = Format(.RecordsetMax, "0000000")
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
End With

If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty

Exit_Function:
Set OpenRecordset = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Set oObject = Nothing
GoTo Exit_Function
End Function ' OpenRecordset V1.1.0
Access2BaseDev DataDef Properties Basic   25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".Properties"
Utils._SetCalledSub(cstThisSub)
vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If
Set vProperty._ParentDatabase = _ParentDatabase

Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Properties
Access2BaseDev DataDef pType Basic Execute (Procedure) 4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function pType() As Integer
pType = _PropertyGet("Type")
End Function ' Type (get)
Access2BaseDev DataDef setProperty Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".getProperty"
Utils._SetCalledSub(cstThisSub)
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub(cstThisSub)
End Function
Access2BaseDev DataDef SQL Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SQL() As Variant
SQL = _PropertyGet("SQL")
End Property ' SQL (get)

Property Let SQL(ByVal pvValue As Variant)
Call _PropertySet("SQL", pvValue)
End Property ' SQL (set)
Access2BaseDev Dialog _GetListener Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
16
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetListener(ByVal psProperty As String) As String
' Return the X...Listener corresponding with the property in argument

Select Case UCase(psProperty)
Case UCase("OnFocusGained"), UCase("OnFocusLost")
_GetListener = "XFocusListener"
Case UCase("OnKeyPressed"), UCase("OnKeyReleased")
_GetListener = "XKeyListener"
Case UCase("OnMouseDragged"), UCase("OnMouseMoved")
_GetListener = "XMouseMotionListener"
Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased")
_GetListener = "XMouseListener"
End Select

End Function ' _GetListener V1.7.0
Access2BaseDev Dialog _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
15
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

If IsLoaded Then
_PropertiesList = Array("Caption", "Height", "IsLoaded", "Name" _
, "OnFocusGained", "OnFocusLost", "OnKeyPressed", "OnKeyReleased", "OnMouseDragged" _
, "OnMouseEntered", "OnMouseExited", "OnMouseMoved", "OnMousePressed", "OnMouseReleased" _
, "ObjectType", "Page", "Visible", "Width" _
)
Else
_PropertiesList = Array("IsLoaded", "Name" _
)
End If

End Function ' _PropertiesList
Access2BaseDev Dialog _PropertyGet Basic Caption (Procedure)
Height (Procedure)
IsLoaded (Procedure)
Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
OnFocusGained (Procedure)
OnFocusLost (Procedure)
OnKeyPressed (Procedure)
OnKeyReleased (Procedure)
OnMouseDragged (Procedure)
OnMouseEntered (Procedure)
OnMouseExited (Procedure)
OnMouseMoved (Procedure)
OnMousePressed (Procedure)
OnMouseReleased (Procedure)
Page (Procedure)
Properties (Procedure)
Visible (Procedure)
Width (Procedure)
getProperty (Procedure)
64
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Dialog.get" & psProperty)

Dim oDialogEvents As Object, sEventName As String

'Execute
_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("Name"), UCase("IsLoaded")
Case Else
If IsNull(UnoDialog) Then Goto Trace_Error_Dialog
End Select
Select Case UCase(psProperty)
Case UCase("Caption")
_PropertyGet = UnoDialog.getTitle()
Case UCase("Height")
_PropertyGet = UnoDialog.getPosSize().Height
Case UCase("IsLoaded")
_PropertyGet = _A2B_.hasItem(COLLALLDIALOGS, _Name)
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
, UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
, UCase("OnMousePressed"), UCase("OnMouseReleased")
Set oDialogEvents = unoDialog.Model.getEvents()
sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty)
If oDialogEvents.hasByName(sEventName) Then
_PropertyGet = oDialogEvents.getByName(sEventName).ScriptCode
Else
_PropertyGet = ""
End If
Case UCase("Page")
_PropertyGet = UnoDialog.Model.Step
Case UCase("Visible")
_PropertyGet = UnoDialog.IsVisible()
Case UCase("Width")
_PropertyGet = UnoDialog.getPosSize().Width
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Dialog.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Dialog:
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Dialog _PropertySet Basic Caption (Procedure)
Height (Procedure)
OnFocusGained (Procedure)
OnFocusLost (Procedure)
OnKeyPressed (Procedure)
OnKeyReleased (Procedure)
OnMouseDragged (Procedure)
OnMouseEntered (Procedure)
OnMouseExited (Procedure)
OnMouseMoved (Procedure)
OnMousePressed (Procedure)
OnMouseReleased (Procedure)
Page (Procedure)
Visible (Procedure)
Width (Procedure)
setProperty (Procedure)
64
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean

Utils._SetCalledSub("Dialog.set" & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function
_PropertySet = True

Dim oDialogEvents As Object, sEventName As String, oEvent As Object, sListener As String, sEvent As String

'Execute
Dim iArgNr As Integer

If _IsLeft(_A2B_.CalledSub, "Dialog.") Then iArgNr = 1 Else iArgNr = 2
If IsNull(UnoDialog) Then Goto Trace_Error_Dialog
Select Case UCase(psProperty)
Case UCase("Caption")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
UnoDialog.setTitle(pvValue)
Case UCase("Height")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
UnoDialog.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT)
Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
, UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
, UCase("OnMousePressed"), UCase("OnMouseReleased")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If Not Utils._RegisterDialogEventScript(UnoDialog.Model _
, psProperty _
, _GetListener(psProperty) _
, pvValue _
) Then GoTo Trace_Error_Dialog
Case UCase("Page")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Then Goto Trace_Error_Value
UnoDialog.Model.Step = pvValue
Case UCase("Visible")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
UnoDialog.setVisible(pvValue)
Case UCase("Width")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value
UnoDialog.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH)
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Dialog.set" & psProperty)
Exit Function
Trace_Error_Dialog:
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
_PropertySet = False
Goto Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev Dialog Caption Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Caption() As Variant
Caption = _PropertyGet("Caption")
End Property ' Caption (get)

Property Let Caption(ByVal pvValue As Variant)
Call _PropertySet("Caption", pvValue)
End Property ' Caption (set)
Access2BaseDev Dialog Class_Initialize Basic Class_Terminate (Procedure) 11
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJDIALOG
_Name = ""
Set _Dialog = Nothing
_Storage = ""
_Library = ""
Set UnoDialog = Nothing
End Sub ' Constructor
Access2BaseDev Dialog Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Dialog Controls Basic OptionGroup (Procedure) 80
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
' Return a Control object with name or index = pvIndex

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Dialog.Controls")

Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer
Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String
Dim j As Integer

Set ocControl = Nothing
If Not IsLoaded Then Goto Trace_Error_NotOpen
Set ocControl = New Control
ocControl._ParentType = CTLPARENTISDIALOG
sParentShortcut = _Shortcut
sControls() = UnoDialog.Model.getElementNames()
iControlCount = UBound(sControls) + 1

If IsMissing(pvIndex) Then ' No argument, return Collection object
Set oCounter = New Collect
oCounter._CollType = COLLCONTROLS
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

Select Case VarType(pvIndex)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index
ocControl._Name = sControls(pvIndex)
Case vbString ' Check control name validity (non case sensitive)
bFound = False
sIndex = UCase(Utils._Trim(pvIndex))
For i = 0 To iControlCount - 1
If UCase(sControls(i)) = sIndex Then
bFound = True
Exit For
End If
Next i
If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound
End Select

ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name)
Set ocControl.ControlModel = UnoDialog.Model.getByName(ocControl._Name)
Set ocControl.ControlView = UnoDialog.getControl(ocControl._Name)
ocControl._ImplementationName = ocControl.ControlModel.getImplementationName()
ocControl._FormComponent = UnoDialog

ocControl._Initialize()
Set Controls = ocControl

Exit_Function:
Utils._ResetCalledSub("Dialog.Controls")
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex))
Set Controls = Nothing
Goto Exit_Function
Trace_Error_NotOpen:
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, , _Name)
Set Controls = Nothing
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set Controls = Nothing
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex))
Set Controls = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog.Controls", Erl)
Set Controls = Nothing
GoTo Exit_Function
End Function ' Controls
Access2BaseDev Dialog Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Dialog EndExecute Basic   32
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub EndExecute(ByVal Optional pvReturn As Variant)
' Stop executing the dialog

If _ErrorHandler() Then On Local Error Goto Error_Sub
Utils._SetCalledSub("Dialog.endExecute")

If IsMissing(pvReturn) Then pvReturn = 0
If Not Utils._CheckArgument(pvReturn, 1, Utils._AddNumeric(), , False) Then Goto Trace_Error

Dim lExecute As Long
lExecute = CLng(pvReturn)
If IsNull(_Dialog) Then Goto Error_Execute
If IsNull(UnoDialog) Then Goto Error_Not_Started
Call UnoDialog.endDialog(lExecute)

Exit_Sub:
Utils._ResetCalledSub("Dialog.endExecute")
Exit Sub
Trace_Error:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array("1", Utils._CStr(pvReturn)))
Goto Exit_Sub
Error_Execute:
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
Goto Exit_Sub
Error_Not_Started:
TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
Goto Exit_Sub
Error_Sub:
TraceError(TRACEABORT, Err, "Dialog.endExecute", Erl)
GoTo Exit_Sub
End Sub ' EndExecute
Access2BaseDev Dialog Execute Basic   32
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Execute() As Long
' Execute dialog

'If _ErrorHandler() Then On Local Error Goto Error_Function
'Seems smart not to trap errors: debugging of dialog events otherwise made very difficult !
Utils._SetCalledSub("Dialog.Execute")

Dim lExecute As Long
If IsNull(_Dialog) Then Goto Error_Execute
If IsNull(UnoDialog) Then Goto Error_Not_Started
lExecute = UnoDialog.execute()

Select Case lExecute
Case 1 : Execute = dlgOK
Case 0 : Execute = dlgCancel
Case Else : Execute = lExecute
End Select

Exit_Function:
Utils._ResetCalledSub("Dialog.Execute")
Exit Function
Error_Execute:
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Not_Started:
TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog.Execute", Erl)
GoTo Exit_Function
End Function ' Execute
Access2BaseDev Dialog getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("Dialog.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Dialog.getProperty")

End Function ' getProperty
Access2BaseDev Dialog hasProperty Basic   8
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
Access2BaseDev Dialog Height Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Height() As Variant
Height = _PropertyGet("Height")
End Property ' Height (get)

Property Let Height(ByVal pvValue As Variant)
Call _PropertySet("Height", pvValue)
End Property ' Height (set)
Access2BaseDev Dialog IsLoaded Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get IsLoaded() As Boolean
IsLoaded = _PropertyGet("IsLoaded")
End Property
Access2BaseDev Dialog Move Basic   57
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Move( ByVal Optional pvLeft As Variant _
, ByVal Optional pvTop As Variant _
, ByVal Optional pvWidth As Variant _
, ByVal Optional pvHeight As Variant _
) As Variant
' Execute Move method
Utils._SetCalledSub("Dialog.Move")
If IsMissing(pvLeft) Then Call _TraceArguments()
On Local Error Goto Error_Function
Move = False
Dim iArgNr As Integer
Select Case UCase(_A2B_.CalledSub)
Case UCase("Move") : iArgNr = 1
Case UCase("Dialog.Move") : iArgNr = 0
End Select
If IsMissing(pvLeft) Then Call _TraceArguments()
If IsMissing(pvTop) Then pvTop = -1
If IsMissing(pvWidth) Then pvWidth = -1
If IsMissing(pvHeight) Then pvHeight = -1
If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function

Dim iArg As Integer, iWrong As Integer ' Check arguments values
iArg = 0
If pvHeight < -1 Then
iArg = 4 : iWrong = pvHeight
ElseIf pvWidth < -1 Then
iArg = 3 : iWrong = pvWidth
ElseIf pvTop < -1 Then
iArg = 2 : iWrong = pvTop
ElseIf pvLeft < -1 Then
iArg = 1 : iWrong = pvLeft
End If
If iArg > 0 Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong))
Goto Exit_Function
End If

Dim iPosSize As Integer
iPosSize = 0
If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X
If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y
If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH
If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT
If iPosSize > 0 Then UnoDialog.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize)
Move = True

Exit_Function:
Utils._ResetCalledSub("Dialog.Move")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog.Move", Erl)
GoTo Exit_Function
End Function ' Move
Access2BaseDev Dialog Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Dialog ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Dialog OnFocusGained Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnFocusGained() As Variant
OnFocusGained = _PropertyGet("OnFocusGained")
End Property ' OnFocusGained (get)

Property Let OnFocusGained(ByVal pvValue As Variant)
Call _PropertySet("OnFocusGained", pvValue)
End Property ' OnFocusGained (set)
Access2BaseDev Dialog OnFocusLost Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnFocusLost() As Variant
OnFocusLost = _PropertyGet("OnFocusLost")
End Property ' OnFocusLost (get)

Property Let OnFocusLost(ByVal pvValue As Variant)
Call _PropertySet("OnFocusLost", pvValue)
End Property ' OnFocusLost (set)
Access2BaseDev Dialog OnKeyPressed Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnKeyPressed() As Variant
OnKeyPressed = _PropertyGet("OnKeyPressed")
End Property ' OnKeyPressed (get)

Property Let OnKeyPressed(ByVal pvValue As Variant)
Call _PropertySet("OnKeyPressed", pvValue)
End Property ' OnKeyPressed (set)
Access2BaseDev Dialog OnKeyReleased Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnKeyReleased() As Variant
OnKeyReleased = _PropertyGet("OnKeyReleased")
End Property ' OnKeyReleased (get)

Property Let OnKeyReleased(ByVal pvValue As Variant)
Call _PropertySet("OnKeyReleased", pvValue)
End Property ' OnKeyReleased (set)
Access2BaseDev Dialog OnMouseDragged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseDragged() As Variant
OnMouseDragged = _PropertyGet("OnMouseDragged")
End Property ' OnMouseDragged (get)

Property Let OnMouseDragged(ByVal pvValue As Variant)
Call _PropertySet("OnMouseDragged", pvValue)
End Property ' OnMouseDragged (set)
Access2BaseDev Dialog OnMouseEntered Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseEntered() As Variant
OnMouseEntered = _PropertyGet("OnMouseEntered")
End Property ' OnMouseEntered (get)

Property Let OnMouseEntered(ByVal pvValue As Variant)
Call _PropertySet("OnMouseEntered", pvValue)
End Property ' OnMouseEntered (set)
Access2BaseDev Dialog OnMouseExited Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseExited() As Variant
OnMouseExited = _PropertyGet("OnMouseExited")
End Property ' OnMouseExited (get)

Property Let OnMouseExited(ByVal pvValue As Variant)
Call _PropertySet("OnMouseExited", pvValue)
End Property ' OnMouseExited (set)
Access2BaseDev Dialog OnMouseMoved Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseMoved() As Variant
OnMouseMoved = _PropertyGet("OnMouseMoved")
End Property ' OnMouseMoved (get)

Property Let OnMouseMoved(ByVal pvValue As Variant)
Call _PropertySet("OnMouseMoved", pvValue)
End Property ' OnMouseMoved (set)
Access2BaseDev Dialog OnMousePressed Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMousePressed() As Variant
OnMousePressed = _PropertyGet("OnMousePressed")
End Property ' OnMousePressed (get)

Property Let OnMousePressed(ByVal pvValue As Variant)
Call _PropertySet("OnMousePressed", pvValue)
End Property ' OnMousePressed (set)
Access2BaseDev Dialog OnMouseReleased Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnMouseReleased() As Variant
OnMouseReleased = _PropertyGet("OnMouseReleased")
End Property ' OnMouseReleased (get)

Property Let OnMouseReleased(ByVal pvValue As Variant)
Call _PropertySet("OnMouseReleased", pvValue)
End Property ' OnMouseReleased (set)
Access2BaseDev Dialog OptionGroup Basic   102
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant
' Return either an error or an object of type OPTIONGROUP based on its name
' A group is determined by the successive TabIndexes of the radio button
' The name of the group = the name of its first element

Utils._SetCalledSub("Dialog.OptionGroup")
If IsMissing(pvGroupName) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function

Set OptionGroup = Nothing
If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function

Dim iAllCount As Integer, iRadioLast As Integer, iGroupCount As Integer, iBegin As Integer, iEnd As Integer
Dim oRadios() As Object, sGroupName As String
Dim i As Integer, j As Integer, bFound As Boolean, ocControl As Object, oRadio As Object, iTabIndex As Integer
Dim ogGroup As Object, vGroup() As Variant, vIndex() As Variant
iAllCount = Controls.Count
If iAllCount > 0 Then
iRadioLast = -1
ReDim oRadios(0 To iAllCount - 1)
For i = 0 To iAllCount - 1 ' Store all RadioButtons objects
Set ocControl = Controls(i)
If ocControl._SubType = CTLRADIOBUTTON Then
iRadioLast = iRadioLast + 1
Set oRadios(iRadioLast) = ocControl
End If
Next i
Else
Goto Error_Arg ' No control in dialog
End If

If iRadioLast < 0 then Goto Error_Arg ' No radio buttons in the dialog

'Resort oRadio array based on tab indexes
If iRadioLast > 0 Then
For i = 0 To iRadioLast - 1 ' Bubble sort
For j = i + 1 To iRadioLast
If oRadios(i).TabIndex > oRadios(j).TabIndex Then
Set oRadio = oRadios(i)
Set oRadios(i) = oRadios(j)
Set oRadios(j) = oRadio
End If
Next j
Next i
End If

'Scan Names to find match with argument
bFound = False
For i = 0 To iRadioLast
If UCase(oRadios(i)._Name) = UCase(pvGroupName) Then
Select Case i
Case 0 : bFound = True
Case Else
If oRadios(i).TabIndex > oRadios(i - 1).TabIndex + 1 Then
bFound = True
Else
Goto Error_Arg ' same group as preceding item although name correct
End If
End Select
If bFound Then
iBegin = i
iEnd = i
sGroupName = oRadios(i)._Name
End If
ElseIf bFound Then
If oRadios(i).TabIndex = oRadios(i - 1).TabIndex + 1 Then iEnd = i
End If
Next i

If bFound Then ' Create OptionGroup
iGroupCount = iEnd - iBegin + 1
Set ogGroup = New OptionGroup
ReDim vGroup(0 To iGroupCount - 1)
ReDim vIndex(0 To iGroupCount - 1)
With ogGroup
._Name = sGroupName
._Count = iGroupCount
._ButtonsGroup = vGroup
._ButtonsIndex = vIndex
For i = 0 To iGroupCount - 1
Set ._ButtonsGroup(i) = oRadios(iBegin + i).ControlModel
._ButtonsIndex(i) = i
Next i
._ParentType = CTLPARENTISDIALOG
._ParentComponent = UnoDialog
End With
Else Goto Error_Arg
End If

Set OptionGroup = ogGroup

Exit_Function:
Utils._ResetCalledSub("Dialog.OptionGroup")
Exit Function
Error_Arg:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog.OptionGroup", Erl)
GoTo Exit_Function
End Function ' OptionGroup V0.9.1
Access2BaseDev Dialog Page Basic   7
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)
Access2BaseDev Dialog pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev Dialog Properties Basic   25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Const cstThisSub = "Dialog.Properties"
Utils._SetCalledSub(cstThisSub)

Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String

vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Properties
Access2BaseDev Dialog setProperty Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Utils._SetCalledSub("Dialog.setProperty")
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub("Dialog.setProperty")
End Function
Access2BaseDev Dialog Start Basic   36
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Start() As Boolean
' Create dialog

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Dialog.Start")

Dim oStart As Object
Start = False
If IsNull(_Dialog) Then Goto Error_Start
If Not IsNull(UnoDialog) Then Goto Error_Yet_Started
Set oStart = CreateUnoDialog(_Dialog)
If IsNull(oStart) Then
Goto Error_Start
Else
Start = True
Set UnoDialog = oStart
With _A2B_
If .hasItem(COLLALLDIALOGS, _Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate
.Dialogs.Add(UnoDialog, UCase(_Name))
End With
End If

Exit_Function:
Utils._ResetCalledSub("Dialog.Start")
Exit Function
Error_Start:
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Yet_Started:
TraceError(TRACEWARNING, ERRDIALOGSTARTED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog.Start", Erl)
GoTo Exit_Function
End Function ' Start
Access2BaseDev Dialog Terminate Basic   28
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Terminate() As Boolean
' Close dialog

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Dialog.Terminate")

Terminate = False
If IsNull(_Dialog) Then Goto Error_Terminate
If IsNull(UnoDialog) Then Goto Error_Not_Started
UnoDialog.Dispose()
Set UnoDialog = Nothing
_A2B_.Dialogs.Remove(_Name)
Terminate = True

Exit_Function:
Utils._ResetCalledSub("Dialog.Terminate")
Exit Function
Error_Terminate:
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Not_Started:
TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Dialog.Terminate", Erl)
GoTo Exit_Function
End Function ' Terminate
Access2BaseDev Dialog Visible Basic   7
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)
Access2BaseDev Dialog Width Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Width() As Variant
Width = _PropertyGet("Width")
End Property ' Width (get)

Property Let Width(ByVal pvValue As Variant)
Call _PropertySet("Width", pvValue)
End Property ' Width (set)
Access2BaseDev DoCmd _CheckColumnType Basic FindRecord (Procedure) 24
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _CheckColumnType(pvFindWhat As Variant, vDataField As Variant) As Boolean
' Return true if both arguments of the same type
' vDataField is a ResultSet column

Dim bFound As Boolean
bFound = False
With com.sun.star.sdbc.DataType
Select Case vDataField.Type
Case .DATE, .TIME, .TIMESTAMP
If VarType(pvFindWhat) = vbDate Then bFound = True
Case .TINYINT, .SMALLINT, .INTEGER, .BIGINT, .FLOAT, .REAL, .DOUBLE, .NUMERIC, .DECIMAL
If Utils._InList(VarType(pvFindWhat), Utils._AddNumeric()) Then bFound = True
Case .CHAR, .VARCHAR, .LONGVARCHAR
If VarType(pvFindWhat) = vbString Then bFound = True
Case Else
End Select
End With

_CheckColumnType = bFound

End Function ' _CheckColumnType V0.9.1
Access2BaseDev DoCmd _ConvertDataDescriptor Basic CopyObject (Procedure) 82
REM -----------------------------------------------------------------------------------------------------------------------
Sub _ConvertDataDescriptor( ByRef poSource As Object _
, ByVal piSourceRDBMS As Integer _
, ByRef poTarget As Object _
, ByRef poDatabase As Object _
, ByVal Optional pbKey As Boolean _
)
' Convert source column descriptor to target descriptor
' If RDMSs identical, simply move property by property
' Otherwise
' - Use Type conversion tables (cfr. DataTypes By RDBMS.ods case study)
' - Select among synonyms the entry with the lowest Precision at least >= source Precision
' - Derive TypeName and Precision values

Dim vTypesReference() As Variant, vTypes() As Variant, vTypeNames() As Variant
Dim i As Integer, iType As Integer, iTypeAlias As Integer
Dim iNbTypes As Integer, iBestFit As Integer, lFitPrecision As Long, lPrecision As Long

On Local Error Goto Error_Sub
If IsMissing(pbKey) Then pbKey = False

poTarget.Name = poSource.Name
poTarget.Description = poSource.Description
If Not pbKey Then
poTarget.ControlDefault = poSource.ControlDefault
poTarget.FormatKey = poSource.FormatKey
poTarget.HelpText = poSource.HelpText
poTarget.Hidden = poSource.Hidden
End If
poTarget.IsCurrency = poSource.IsCurrency
poTarget.IsNullable = poSource.IsNullable
poTarget.Scale = poSource.Scale

If piSourceRDBMS = poDatabase._RDBMS Or poDatabase._RDBMS = DBMS_UNKNOWN Then
poTarget.Type = poSource.Type
poTarget.Precision = poSource.Precision
poTarget.TypeName = poSource.TypeName
Goto Exit_Sub
End If

' Search DataType compatibility
With poDatabase
' Find source datatype entry in Reference array
iType = -1
For i = 0 To UBound(._ColumnTypesReference)
If ._ColumnTypesReference(i) = poSource.Type Then
iType = i
Exit For
End If
Next i
If iType = -1 Then Goto Error_Compatibility
iTypeAlias = ._ColumnTypesAlias(iType)
' Find best choice for the datatype of the target column
iNbTypes = UBound(._ColumnTypes)
iBestFit = -1
lFitPrecision = -2 ' Some POSTGRES datatypes have a precision of -1
For i = 0 To iNbTypes
If ._ColumnTypes(i) = iTypeAlias Then ' Minimal fit = correct datatype
lPrecision = ._ColumnPrecisions(i)
If iBestFit = -1 _
Or (iBestFit > -1 And poSource.Precision > 0 And lPrecision >= poSource.Precision And lPrecision < lFitPrecision) _
Or (iBestFit > -1 And poSource.Precision = 0 And lPrecision > lFitPrecision) Then ' First fit or better fit
iBestFit = i
lFitPrecision = lPrecision
End If
End If
Next i
If iBestFit = -1 Then Goto Error_Compatibility
poTarget.Type = iTypeAlias
poTarget.Precision = lFitPrecision
poTarget.TypeName = ._ColumnTypeNames(iBestFit)
End With

Exit_Sub:
Exit Sub
Error_Compatibility:
TraceError(TRACEFATAL, ERRCOMPATIBILITY, Utils._CalledSub(), 0, 1, poSource.Name)
Goto Exit_Sub
Error_Sub:
TraceError(TRACEABORT, Err, "_ConvertDataDescriptor", Erl)
Goto Exit_Sub
End Sub ' ConvertDataDescriptor V1.6.0
Access2BaseDev DoCmd _DatabaseForm Basic ApplyFilter (Procedure)
GoToRecord (Procedure)
SetOrderBy (Procedure)
41
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _DatabaseForm(psForm As String, psControl As String)
'Return DatabaseForm element of Form object (based on psForm which is known as a real form name)
'or of SubForm object (based on psControl which is checked for being a subform)

Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer
Dim bFound As Boolean, i As Integer, sName As String

Set oForm = Application.Forms(psForm)
If psControl <> "" Then ' Search subform
With oForm.DatabaseForm
iControlCount = .getCount()
bFound = False
If iControlCount > 0 Then
sControls() = .getElementNames()
sName = UCase(Utils._Trim(psControl))
For i = 0 To iControlCount - 1
If UCase(sControls(i)) = sName Then
bFound = True
Exit For
End If
Next i
End If
End With
If bFound Then sName = sControls(i) Else Goto Trace_NotFound
Set oControl = oForm.Controls(sName)
If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound
Set _DatabaseForm = oControl.Form.DatabaseForm
Else
Set _DatabaseForm = oForm.DatabaseForm
End If

Exit_Function:
Exit Function
Trace_NotFound:
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm))
Goto Exit_Function
Trace_SubFormNotFound:
TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm))
Goto Exit_Function
End Function ' _DatabaseForm V1.2.0
Access2BaseDev DoCmd _DispatchCommand Basic RunCommand (Procedure) 13
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _DispatchCommand(ByVal psCommand As String)
' Execute command given as argument - ".uno:" is presumed already present
Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String
Dim oResult As Variant
Dim sCommand As String

Set oDocument = _SelectWindow().Frame
Set oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
sTargetFrameName = ""
oResult = oDispatcher.executeDispatch(oDocument, psCommand, sTargetFrameName, 0, oArgs())

End Sub ' _DispatchCommand V1.3.0
Access2BaseDev DoCmd _getUpperShortcut Basic FindRecord (Procedure)
setFocus (Procedure)
11
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal psLastComponent As String) As String
' Return "Forms!myForm" from "Forms!myForm!datField" and "datField"

If Len(psShortcut) > Len(psLastComponent) Then
_getUpperShortcut = Split(psShortcut, "!" & Utils._Surround(psLastComponent))(0)
Else
_getUpperShortcut = psShortcut
End If

End Function ' _getUpperShortcut
Access2BaseDev DoCmd _OpenObject Basic OpenQuery (Procedure)
OpenReport (Procedure)
OpenTable (Procedure)
72
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OpenObject(ByVal psObjectType As String _
, ByVal pvObjectName As Variant _
, ByVal pvView As Variant _
, ByVal pvDataMode As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function

_OpenObject = False
If Not (Utils._CheckArgument(pvObjectName, 1, vbString) _
And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _
And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _
) Then Goto Exit_Function
Dim oDatabase As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object
Dim i As Integer, bFound As Boolean, lComponent As Long, oQuery As Object

' Check existence of object and find its exact (case-sensitive) name
Select Case psObjectType
Case "Table"
sObjects = oDatabase.Connection.getTables.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE
Case "Query"
sObjects = oDatabase.Connection.getQueries.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY
Case "Report"
sObjects = oDatabase.Document.getReportDocuments.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT
End Select
bFound = False
For i = 0 To UBound(sObjects)
If UCase(pvObjectName) = UCase(sObjects(i)) Then
sObjectName = sObjects(i)
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound

If psObjectType = "Query" Then ' Processing for action query
Set oQuery = Application._CurrentDb().QueryDefs(pvObjectName)
If oQuery.pType <> dbQSelect Then
_OpenObject = oQuery.Execute()
GoTo Exit_Function
End If
End If
Set oController = oDatabase.Document.CurrentController
Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign ))
_OpenObject = True

Exit_Function:
Set oObject = Nothing
Set oQuery = Nothing
Set oController = Nothing
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenObject", Erl)
GoTo Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName))
Goto Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1)
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName))
Goto Exit_Function
End Function ' _OpenObject V0.8.9
Access2BaseDev DoCmd _PromptFormat Basic OutputTo (Procedure)
SendObject (Procedure)
OutputTo (Procedure)
44
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PromptFormat(ByVal pvList As Variant) As String
' Return user selection in Format dialog

Dim oDialog As Object, iOKCancel As Integer, oControl As Object

Set oDialog = CreateUnoDialog(Utils._GetDialogLib().dlgFormat)
oDialog.Title = _GetLabel("DLGFORMAT_TITLE")

Set oControl = oDialog.Model.getByName("lblFormat")
oControl.Label = _GetLabel("DLGFORMAT_LBLFORMAT_LABEL")
oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP")

Set oControl = oDialog.Model.getByName("cboFormat")
oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP")

Set oControl = oDialog.Model.getByName("cmdOK")
oControl.Label = _GetLabel("DLGFORMAT_CMDOK_LABEL")
oControl.HelpText = _GetLabel("DLGFORMAT_CMDOK_HELP")

Set oControl = oDialog.Model.getByName("cmdCancel")
oControl.Label = _GetLabel("DLGFORMAT_CMDCANCEL_LABEL")
oControl.HelpText = _GetLabel("DLGFORMAT_CMDCANCEL_HELP")

Set oControl = oDialog.Model.getByName("cboFormat")
If UBound(pvList) >= 0 Then
oControl.Text = pvList(0)
oControl.StringItemList = pvList
Else
oControl.Text = ""
oControl.StringItemList = Array()
End If

iOKCancel = oDialog.Execute()
Select Case iOKCancel
Case 1 ' OK
_PromptFormat = oControl.Text
Case 0 ' Cancel
_PromptFormat = ""
Case Else
End Select
oDialog.Dispose()

End Function ' _PromptFormat V0.8.5
Access2BaseDev DoCmd _SelectWindow Basic CommandBars (Procedure)
_NewBar (Procedure)
ApplyFilter (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
Maximize (Procedure)
Minimize (Procedure)
MoveSize (Procedure)
OutputTo (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
_DispatchCommand (Procedure)
151
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional ByVal psWindow As String) As Object
' No argument: find active window
' 2 arguments: find corresponding window
' Return a _Window object type describing the found window

Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer
Dim bFound As Boolean, bActive As Boolean, sName As String, iType As Integer, sDocumentType As String
Dim sImplementation As String, vLocation() As Variant
Dim oWindow As _Window

If _ErrorHandler() Then On Local Error Goto Error_Function

bActive = IsMissing(piWindowType)
If IsMissing(psWindow) Then psWindow = ""
Set oWindow.Frame = Nothing
oWindow.DocumentType = ""
If bActive Then
oWindow.WindowType = acDefault
oWindow._Name = ""
Else
oWindow.WindowType = piWindowType
Select Case piWindowType
Case acBasicIDE, acDatabaseWindow : oWindow._Name = ""
Case Else : oWindow._Name = psWindow
End Select
End If
iType = acDefault
sDocumentType = ""

Set oDesk = CreateUnoService("com.sun.star.frame.Desktop")
Set oEnum = oDesk.Components().createEnumeration
Do While oEnum.hasMoreElements
Set oComp = oEnum.nextElement
If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = ""
Select Case sImplementation
Case "com.sun.star.comp.basic.BasicIDE"
Set oFrame = oComp.CurrentController.Frame
iType = acBasicIDE
sName = ""
Case "com.sun.star.comp.dba.ODatabaseDocument"
Set oFrame = oComp.CurrentController.Frame
iType = acDatabaseWindow
sName = ""
Case "SwXTextDocument"
If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then
Select Case oComp.Identifier
Case "com.sun.star.sdb.FormDesign" ' Form
iType = acForm
Case "com.sun.star.sdb.TextReportDesign" ' Report
iType = acReport
Case "com.sun.star.text.TextDocument" ' Writer
vLocation = Split(oComp.getLocation(), "/")
If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = ""
iType = acDocument
sDocumentType = docWriter
End Select
If iType = acForm Or iType = acReport Then ' Identify Form or Report name
For i = 0 To UBound(oComp.Args())
If oComp.Args(i).Name = "DocumentTitle" Then
sName = oComp.Args(i).Value
Exit For
End If
Next i
End If
Set oFrame = oComp.CurrentController.Frame
End If
Case "org.openoffice.comp.dbu.ODatasourceBrowser"
Set oFrame = oComp.Frame
If Not IsEmpty(oComp.Selection) Then ' Empty for (F4) DatasourceBrowser !!
For i = 0 To UBound(oComp.Selection())
If oComp.Selection(i).Name = "Command" Then
sName = oComp.Selection(i).Value
ElseIf oComp.Selection(i).Name = "CommandType" Then
Select Case oComp.selection(i).Value
Case com.sun.star.sdb.CommandType.TABLE
iType = acTable
Case com.sun.star.sdb.CommandType.QUERY
iType = acQuery
Case com.sun.star.sdb.CommandType.COMMAND
iType = acQuery ' SQL for future use ?
End Select
End If
Next i
' Else ignore
End If
Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode
If Not bActive Then
If UCase(Right(oComp.Title, Len(psWindow))) = UCase(psWindow) Then ' No rigorous mean found to identify Name
Set oFrame = oComp.Frame
Select Case sImplementation
Case "org.openoffice.comp.dbu.OTableDesign" : iType = acTable
Case "org.openoffice.comp.dbu.OQueryDesign" : iType = acQuery
End Select
sName = Right(oComp.Title, Len(psWindow))
End If
Else
Set oFrame = Nothing
End If
Case "org.openoffice.comp.dbu.ORelationDesign"
Set oFrame = oComp.Frame
iType = acDiagram
sName = ""
Case "com.sun.star.comp.sfx2.BackingComp" ' Welcome screen
Set oFrame = oComp.Frame
iType = acWelcome
sName = ""
Case Else ' Other Calc, ..., whatever documents
If Utils._hasUNOProperty(oComp, "Location") Then
vLocation = Split(oComp.getLocation(), "/")
If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = ""
iType = acDocument
If Utils._hasUNOProperty(oComp, "Identifier") Then
Select Case oComp.Identifier
Case "com.sun.star.sheet.SpreadsheetDocument" : sDocumentType = docCalc
Case "com.sun.star.presentation.PresentationDocument" : sDocumentType = docImpress
Case "com.sun.star.drawing.DrawingDocument" : sDocumentType = docDraw
Case "com.sun.star.formula.FormulaProperties" : sDocumentType = docMath
Case Else : sDocumentType = ""
End Select
End If
Set oFrame = oComp.CurrentController.Frame
End If
End Select
If bActive And Not IsNull(oFrame) Then
If oFrame.ContainerWindow.IsActive() Then
bFound = True
Exit Do
End If
ElseIf iType = piWindowType And UCase(sName) = UCase(psWindow) Then
bFound = True
Exit Do
End If
Loop

If bFound Then
Set oWindow.Frame = oFrame
oWindow._Name = sName
oWindow.WindowType = iType
oWindow.DocumentType = sDocumentType
Else
Set oWindow.Frame = Nothing
End If

Exit_Function:
Set _SelectWindow = oWindow
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "SelectWindow", Erl)
GoTo Exit_Function
End Function ' _SelectWindow V1.1.0
Access2BaseDev DoCmd _SendWithAttachment Basic SendObject (Procedure) 105
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _SendWithAttachment( _
ByVal pvRecipients() As Variant _
, ByVal pvCcRecipients() As Variant _
, ByVal pvBccRecipients() As Variant _
, ByVal psSubject As String _
, ByVal pvAttachments() As Variant _
, ByVal pvBody As String _
, ByVal pbEditMessage As Boolean _
) As Boolean

' Send message with attachments
If _ErrorHandler() Then On Local Error Goto Error_Function
_SendWithAttachment = False

Const cstWindows = 1
Const cstLinux = 4
Const cstSemiColon = ";"
Dim oServiceMail as Object, oMail As Object, oMessage As Object, vFlag As Variant
Dim vCc() As Variant, i As Integer, iOS As Integer, sProduct As String, bMailProvider As Boolean

'OPENOFFICE <= 3.6 and LIBREOFFICE have XSimple...Mail interface while OPENOFFICE >= 4.0 has XSystemMailProvider interface
sProduct = UCase(Utils._GetProductName())
bMailProvider = ( Left(sProduct, 4) = "OPEN" And Left(_GetProductName("VERSION"), 3) >= "4.0" )

iOS = GetGuiType()
Select Case iOS
Case cstLinux
oServiceMail = createUnoService("com.sun.star.system.SimpleCommandMail")
Case cstWindows
If bMailProvider Then oServiceMail = createUnoService("com.sun.star.system.SystemMailProvider") _
Else oServiceMail = createUnoService("com.sun.star.system.SimpleSystemMail")
Case Else
Goto Error_Mail
End Select

If bMailProvider Then Set oMail = oServiceMail.queryMailClient() _
Else Set oMail = oServiceMail.querySimpleMailClient()
If IsNull(oMail) Then Goto Error_Mail

'Reattribute Recipients >= 2nd to ccRecipients
If UBound(pvRecipients) <= 0 Then
If UBound(pvCcRecipients) >= 0 Then vCc = pvCcRecipients
Else
ReDim vCc(0 To UBound(pvRecipients) - 1 + UBound(pvCcRecipients) + 1)
For i = 0 To UBound(pvRecipients) - 1
vCc(i) = pvRecipients(i + 1)
Next i
For i = UBound(pvRecipients) To UBound(vCc)
vCc(i) = pvCcRecipients(i - UBound(pvRecipients))
Next i
End If

If bMailProvider Then
Set oMessage = oMail.createMailMessage()
If UBound(pvRecipients) >= 0 Then oMessage.Recipient = pvRecipients(0)
If psSubject <> "" Then oMessage.Subject = psSubject
Select Case iOS ' Not published differences between com.sun.star.system.SimpleCommandMail and SimpleSystemMail
Case cstLinux
If UBound(vCc) >= 0 Then oMessage.CcRecipient = Array(Join(vCc, cstSemiColon))
If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = Array(Join(pvBccRecipients, cstSemiColon))
Case cstWindows
If UBound(vCc) >= 0 Then oMessage.CcRecipient = vCc
If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = pvBccRecipients
End Select
If UBound(pvAttachments) >= 0 Then oMessage.Attachement = pvAttachments
If pvBody <> "" Then oMessage.Body = pvBody
If pbEditMessage Then
vFlag = com.sun.star.system.MailClientFlags.DEFAULTS
Else
vFlag = com.sun.star.system.MailClientFlags.NO_USER_INTERFACE
End If
oMail.sendMailMessage(oMessage, vFlag)
Else
Set oMessage = oMail.createSimpleMailMessage() ' Body NOT SUPPORTED !
If UBound(pvRecipients) >= 0 Then oMessage.setRecipient(pvRecipients(0))
If psSubject <> "" Then oMessage.setSubject(psSubject)
Select Case iOS
Case cstLinux
If UBound(vCc) >= 0 Then oMessage.setCcRecipient(Array(Join(vCc, cstSemiColon)))
If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(Array(Join(pvBccRecipients, cstSemiColon)))
Case cstWindows
If UBound(vCc) >= 0 Then oMessage.setCcRecipient(vCc)
If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(pvBccRecipients)
End Select
If UBound(pvAttachments) >= 0 Then oMessage.setAttachement(pvAttachments)
If pbEditMessage Then
vFlag = com.sun.star.system.SimpleMailClientFlags.DEFAULTS
Else
vFlag = com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE
End If
oMail.sendSimpleMailMessage(oMessage, vFlag)
End If

_SendWithAttachment = True

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "_SendWithAttachment", Erl)
Goto Exit_Function
Error_Mail:
TraceError(TRACEFATAL, ERRSENDMAIL, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' _SendWithAttachment V0.9.5
Access2BaseDev DoCmd _SendWithoutAttachment Basic SendObject (Procedure) 38
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _SendWithoutAttachment(ByVal pvTo As Variant _
, ByVal pvCc As Variant _
, ByVal pvBcc As Variant _
, ByVal psSubject As String _
, ByVal psBody As String _
) As Boolean
'Send simple message with mailto: syntax
Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object
Const cstComma = ","

If _ErrorHandler() Then On Local Error Goto Error_Function

If UBound(pvTo) >= 0 Then sTo = Trim(Join(pvTo, cstComma)) Else sTo = ""
If UBound(pvCc) >= 0 Then sCc = Trim(Join(pvCc, cstComma)) Else sCc = ""
If UBound(pvBcc) >= 0 Then sBcc = Trim(Join(pvBcc, cstComma)) Else sBcc = ""

sMailTo = "mailto:" _
& sTo & "?" _
& Iif(sCc = "", "", "cc=" & sCc & "&") _
& Iif(sBcc = "", "", "bcc=" & sBcc & "&") _
& Iif(psSubject = "", "", "subject=" & psSubject & "&") _
& Iif(psBody = "", "", "body=" & psBody & "&")
If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1)
sMailTo = ConvertToUrl(sMailTo)

oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper")
oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array())

_SendWithoutAttachment = True

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "_SendWithoutAttachments", Erl)
_SendWithoutAttachment = False
Goto Exit_Function
End Function ' _SendWithoutAttachment V0.8.5
Access2BaseDev DoCmd _ShellExecute Basic OpenHelpFile (Procedure)
OutputTo (Procedure)
RunApp (Procedure)
OutputTo (Procedure)
9
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _ShellExecute(sCommand As String)
' Execute shell command

Dim oShell As Object
Set oShell = createUnoService("com.sun.star.system.SystemShellExecute")
oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.DEFAULTS)

End Sub ' _ShellExecute V0.8.5
Access2BaseDev DoCmd ApplyFilter Basic   61
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ApplyFilter( _
ByVal Optional pvFilter As Variant _
, ByVal Optional pvSQL As Variant _
, ByVal Optional pvControlName As Variant _
) As Boolean
' Set filter on open table, query, form or subform (if pvControlName present)

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "ApplyFilter"
Utils._SetCalledSub(cstThisSub)
ApplyFilter = False

If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments()
If IsMissing(pvFilter) Then pvFilter = ""
If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function
If IsMissing(pvSQL) Then pvSQL = ""
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
If IsMissing(pvControlName) Then pvControlName = ""
If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function

Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

If pvSQL <> "" _
Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _
Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter)

Set oWindow = _SelectWindow()
With oWindow
Select Case .WindowType
Case acForm
Set oTarget = _DatabaseForm(._Name, pvControlName)
Case acQuery, acTable
If pvControlName <> "" Then Goto Exit_Function
If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
' FormOperations returns <Null> in OpenOffice
Set oTarget = .Frame.Controller.FormOperations.Cursor
Case Else ' Ignore action
Goto Exit_Function
End Select
End With

With oTarget
.Filter = sFilter
.ApplyFilter = True
.reload()
End With
ApplyFilter = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' ApplyFilter V1.2.0
Access2BaseDev DoCmd CopyObject Basic   237
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CopyObject(ByVal Optional pvSourceDatabase As Variant _
, ByVal Optional pvNewName As Variant _
, ByVal Optional pvSourceType As Variant _
, ByVal Optional pvSourceName As Variant _
) As Boolean
' Copies tables and queries into identical (new) objects
If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "CopyObject"
Utils._SetCalledSub(cstThisSub)
CopyObject = False

If IsMissing(pvSourceDatabase) Then pvSourceDatabase = ""
If VarType(pvSourceDatabase) <> vbString Then
If Not Utils._CheckArgument(pvSourceDatabase, 1, OBJDATABASE) Then Goto Exit_Function
End If
If IsMissing(pvNewName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function
If IsMissing(pvSourceType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _
) Then Goto Exit_Function
If IsMissing(pvSourceName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto Exit_Function

Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase As Object, bSameDatabase As Boolean
Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object, oTargetCol As Object, iRDBMS As Integer
Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object
Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant
Dim vNameComponents() As Variant, iNames As Integer, sSurround As String
Dim vInputField As Variant, vFieldBinary() As Variant, vOutputField As Variant
Dim oInput as Object, oOutput As Object, iNbFields As Integer, vValue As Variant
Dim vBinary As Variant, lInputSize As Long, lOutputSize As Long
Dim lInputRecs As Long, lInputMax As Long, vField As Variant, bProgressMeter As Boolean, sFile As String

Const cstMaxBinlength = 2 * 65535
Const cstChunkSize = 2 * 65535
Const cstProgressMeterLimit = 100

Set oDatabase = Application._CurrentDb()
bSameDatabase = False
If VarType(pvSourceDatabase) = vbString Then
If pvSourceDatabase = "" Then
Set oSourceDatabase = oDatabase
bSameDatabase = True
Else
Set oSourceDatabase = Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), , , True)
If IsNull(oSourceDatabase) Then Goto Exit_Function
End If
Else
Set oSourceDatabase = pvSourceDatabase
End If

With oDatabase
iRDBMS = ._RDBMS
If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
Select Case pvSourceType

Case acQuery
Set oSource = oSourceDatabase.QueryDefs(pvSourceName, True)
If IsNull(oSource) Then Goto Error_NotFound
Set oTarget = .QueryDefs(pvNewName, True)
If Not IsNull(oTarget) Then .Connection.getQueries.dropByName(oTarget.Name) ' a query with same name exists already ... drop it
If oSource.Query.EscapeProcessing Then
Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL)
Else
Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough)
End If
' Save .odb document
.Document.store()

Case acTable
Set oSource = oSourceDatabase.TableDefs(pvSourceName, True)
If IsNull(oSource) Then Goto Error_NotFound
Set oTarget = .TableDefs(pvNewName, True)
' A table with same name exists already ... drop it
If Not IsNull(oTarget) Then .Connection.getTables.dropByName(oTarget.Name)
' Copy source table columns
Set oSourceTable = oSource.Table
Set oTarget = .Connection.getTables.createDataDescriptor
oTarget.Description = oSourceTable.Description
vNameComponents = Split(pvNewName, ".")
iNames = UBound(vNameComponents)
If iNames >= 2 Then oTarget.CatalogName = vNameComponents(iNames - 2) Else oTarget.CatalogName = ""
If iNames >= 1 Then oTarget.SchemaName = vNameComponents(iNames - 1) Else oTarget.SchemaName = ""
oTarget.Name = vNameComponents(iNames)
oTarget.Type = oSourceTable.Type
Set oSourceColumns = oSourceTable.Columns
Set oTargetCol = oTarget.Columns.createDataDescriptor
For i = 0 To oSourceColumns.getCount() - 1
' Append each individual column to the table descriptor
Set oSourceCol = oSourceColumns.getByIndex(i)
_ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase
oTarget.Columns.appendByDescriptor(oTargetCol)
Next i
' Copy keys
Set oSourceKeys = oSourceTable.Keys
Set oTargetKey = oTarget.Keys.createDataDescriptor()
For i = 0 To oSourceKeys.getCount() - 1
' Append each key to table descriptor
Set oSourceKey = oSourceKeys.getByIndex(i)
oTargetKey.DeleteRule = oSourceKey.DeleteRule
oTargetKey.Name = oSourceKey.Name
oTargetKey.ReferencedTable = oSourceKey.ReferencedTable
oTargetKey.Type = oSourceKey.Type
oTargetKey.UpdateRule = oSourceKey.UpdateRule
Set oTargetCol = oTargetKey.Columns.createDataDescriptor()
For j = 0 To oSourceKey.Columns.getCount() - 1
Set oSourceCol = oSourceKey.Columns.getByIndex(j)
_ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase, True
oTargetKey.Columns.appendByDescriptor(oTargetCol)
Next j
oTarget.Keys.appendByDescriptor(oTargetKey)
Next i
' Duplicate table whole design
.Connection.getTables.appendByDescriptor(oTarget)

' Copy data
Select Case bSameDatabase
Case True
' Build SQL statement to copy data
sSurround = Utils._Surround(oSource.Name)
sSql = "INSERT INTO " & Utils._Surround(pvNewName) & " SELECT " & sSurround & ".* FROM " & sSurround
DoCmd.RunSQL(sSql)
Case False
' Copy data row by row and field by field
' As it is slow ... display a progress meter
Set oInput = oSourceDatabase.OpenRecordset(oSource.Name, , , dbReadOnly)
Set oOutput = .Openrecordset(pvNewName)

With oInput
If Not ( ._BOF And ._EOF ) Then
.MoveLast
lInputMax = .RecordCount
lInputRecs = 0
.MoveFirst
bProgressMeter = ( lInputMax > cstProgressMeterLimit )

iNbFields = .Fields().Count - 1
vFieldBinary = Array()
ReDim vFieldBinary(0 To iNbFields)
For i = 0 To iNbFields
vFieldBinary(i) = Utils._IsBinaryType(.Fields(i).Column.Type)
Next i
Else
bProgressMeter = False
End If
If bProgressMeter Then Application.SysCmd acSysCmdInitMeter, pvNewName & " 0 %", lInputMax
Do While Not .EOF()
oOutput.RowSet.moveToInsertRow()
oOutput._EditMode = dbEditAdd
For i = 0 To iNbFields
Set vInputField = .Fields(i)
Set vOutputField = oOutput.Fields(i)
If vFieldBinary(i) Then
lInputSize = vInputField.FieldSize
If lInputSize <= cstMaxBinlength Then
vField = Utils._getResultSetColumnValue(.RowSet, i + 1, True)
Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField)
ElseIf oDatabase._BinaryStream Then
' Typically for SQLite where binary fields are limited
If lInputSize > vOutputField._Precision Then
TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1))
Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, Null)
Else
sFile = Utils._GetRandomFileName("BINARY")
vInputField._WriteAll(sFile, "WriteAllBytes")
vOutputField._ReadAll(sFile, "ReadAllBytes")
Kill ConvertToUrl(sFile)
End If
End If
Else
vField = Utils._getResultSetColumnValue(.RowSet, i + 1)
If VarType(vField) = vbString Then
If Len(vField) > vOutputField._Precision Then
TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1))
End If
End If
' Update is done anyway, if too long, with truncation
Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField)
End If
Next i
If oOutput.RowSet.IsNew And oOutput.RowSet.IsModified Then oOutput.RowSet.insertRow()
oOutput._EditMode = dbEditNone
lInputRecs = lInputRecs + 1
If bProgressMeter Then
If lInputRecs Mod (lInputMax / 100) = 0 Then
Application.SysCmd acSysCmdUpdateMeter, pvNewName & " " & CStr(CLng(lInputRecs * 100 / lInputMax)) & "%", lInputRecs
End If
End If
.MoveNext
Loop
End With

oOutput.mClose()
Set oOutput = Nothing
oInput.mClose()
Set oInput = Nothing
if bProgressMeter Then Application.SysCmd acSysCmdClearStatus
End Select

Case Else
End Select
End With

CopyObject = True

Exit_Function:
' Avoid closing the current database or the database object given as source argument
If VarType(pvSourceDatabase) = vbString And Not bSameDatabase Then
If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose()
End If
Set oSourceDatabase = Nothing
If Not IsNull(oOutput) Then oOutput.mClose()
Set oOutput = Nothing
If Not IsNull(oInput) Then oInput.mClose()
Set oInput = Nothing
Set oSourceCol = Nothing
Set oSourceKey = Nothing
Set oSourceKeys = Nothing
Set oSource = Nothing
Set oSourceTable = Nothing
Set oSourceColumns = Nothing
Set oTargetCol = Nothing
Set oTargetKey = Nothing
Set oTarget = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName))
Goto Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' CopyObject V1.1.0
Access2BaseDev DoCmd FindNext Basic FindRecord (Procedure) 124
REM -----------------------------------------------------------------------------------------------------------------------
Public Function FindNext() As Boolean
' Must be called after a FindRecord
' Execute instructions set in FindRecord object

If _ErrorHandler() Then On Local Error Goto Error_Function
FindNext = False
Utils._SetCalledSub("FindNext")

Dim ofForm As Object, ocGrid As Object
Dim i As Integer, lInitialRow As Long, lFindRow As Long
Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean
Dim vFindValue As Variant, oFindrecord As Object

Set oFindRecord = _A2B_.FindRecord
If IsNull(oFindRecord) Then GoTo Error_FindRecord
With oFindRecord

If .FindRecord = 0 Then Goto Error_FindRecord
.FindRecord = 0
Set ofForm = getObject(.Form)
If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola
Set ocGrid = getObject(.GridControl)

' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween
If ofForm.DatabaseForm.RowCount <= 0 then Goto Exit_Function ' Dataset is empty

lInitialRow = .LastRow ' Used if Search = acSearchAll

bFound = False
lFindRow = .LastRow
b2ndRound = False
Do
' Last column ? Go to next row
If .LastColumn >= UBound(.ColumnNames) Then
bStop = False
If ofForm.DatabaseForm.isAfterLast() And .Search = acUp Then
ofForm.DatabaseForm.last()
ElseIf ofForm.DatabaseForm.isLast() And .Search = acSearchAll Then
ofForm.DatabaseForm.first()
b2ndRound = True
ElseIf ofForm.DatabaseForm.isBeforeFirst() And (.Search = acDown Or .Search = acSearchAll) Then
ofForm.DatabaseForm.first()
ElseIf ofForm.DatabaseForm.isFirst() And .search = acUp Then
ofForm.DatabaseForm.beforeFirst()
bStop = True
ElseIf ofForm.DatabaseForm.isLast() And .search = acDown Then
ofForm.DatabaseForm.afterLast()
bStop = True
ElseIf .Search = acUp Then
ofForm.DatabaseForm.previous()
Else
ofForm.DatabaseForm.next()
End If
lFindRow = ofForm.DatabaseForm.getRow()
If bStop Or (.Search = acSearchAll And lFindRow >= lInitialRow And b2ndRound) Then
ofForm.DatabaseForm.absolute(lInitialRow)
Exit Do
End If
.LastColumn = 0
Else
.LastColumn = .LastColumn + 1
End If

' Examine column contents
If .LastColumn <= UBound(.ColumnNames) Then
For i = .LastColumn To UBound(.ColumnNames)
vFindValue = Utils._getResultSetColumnValue(ofForm.DatabaseForm.createResultSet(), .ResultSetIndex(i))
Select Case VarType(.FindWhat)
Case vbDate, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
bFound = ( .FindWhat = vFindValue )
Case vbString
If VarType(vFindValue) = vbString Then
Select Case .Match
Case acStart
If .MatchCase Then
bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue )
Else
bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) )
End If
Case acAnyWhere
If .MatchCase Then
bFound = ( InStr(1, vFindValue, .FindWhat, 0) > 0 )
Else
bFound = ( InStr(vFindValue, .FindWhat) > 0 )
End If
Case acEntire
If .MatchCase Then
bFound = ( .FindWhat = vFindValue )
Else
bFound = ( UCase(.FindWhat) = UCase(vFindValue) )
End If
End Select
Else
bFound = False
End If
End Select
If bFound Then
.LastColumn = i
Exit For
End If
Next i
End If
Loop While Not bFound

.LastRow = lFindRow
If bFound Then
ocGrid.Controls(.ColumnNames(.LastColumn)).setFocus()
.FindRecord = 1
FindNext = True
End If

End With

Exit_Function:
Utils._ResetCalledSub("FindNext")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "FindNext", Erl)
GoTo Exit_Function
Error_FindRecord:
TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' FindNext V1.1.0
Access2BaseDev DoCmd FindRecord Basic Class_Initialize (Procedure) 233
REM -----------------------------------------------------------------------------------------------------------------------
Public Function FindRecord(Optional ByVal pvFindWhat As Variant _
, Optional ByVal pvMatch As Variant _
, Optional ByVal pvMatchCase As Variant _
, Optional ByVal pvSearch As Variant _
, Optional ByVal pvSearchAsFormatted As Variant _
, Optional ByVal pvTargetedField As Variant _
, Optional ByVal pvFindFirst As Variant _
) As Boolean

'Find a value (string or other) in the underlying data of a gridcontrol
'Search in all columns or only in one single control
' see pvTargetedField = acAll or acCurrent
' pvTargetedField may also be a shortcut to a GridControl or one of its subcontrols
'Initialize _Findrecord structure in Database root and call FindNext() to set cursor on found value

If _ErrorHandler() Then On Local Error Goto Error_Function
FindRecord = False

Utils._SetCalledSub("FindRecord")
If IsMissing(pvFindWhat) Or pvFindWhat = "" Then Call _TraceArguments()
If IsMissing(pvMatch) Then pvMatch = acEntire
If IsMissing(pvMatchCase) Then pvMatchCase = False
If IsMissing(pvSearch) Then pvSearch = acSearchAll
If IsMissing(pvSearchAsFormatted) Then pvSearchAsFormatted = False ' Anyway only False supported
If IsMissing(pvTargetedField) Then pvTargetedField = acCurrent
If IsMissing(pvFindFirst) Then pvFindFirst = True
If Not (Utils._CheckArgument(pvFindWhat, 1, Utils._AddNumeric(Array(vbString, vbDate))) _
And Utils._CheckArgument(pvMatch, 2, Utils._AddNumeric(), Array(acAnywhere, acEntire, acStart)) _
And Utils._CheckArgument(pvMatchCase, 3, vbBoolean) _
And Utils._CheckArgument(pvSearch, 4, Utils._AddNumeric(), Array(acDown, acSearchAll, acUp)) _
And Utils._CheckArgument(pvSearchAsFormatted, 5, vbBoolean, Array(False)) _
And Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(vbString)) _
And Utils._CheckArgument(pvFindFirst, 7, vbBoolean) _
) Then Exit Function
If VarType(pvTargetedField) <> vbString Then
If Not Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(), Array(acAll, acCurrent)) Then Exit Function
End If

Dim ocTarget As Object, i As Integer, j As Integer, vNames() As Variant, iCount As Integer, vIndexes() As Variant
Dim vColumn As Variant, vDataField As Variant, ofParentForm As Variant, oColumns As Object, vParentGrid As Object
Dim bFound As Boolean, ocGridControl As Object, iFocus As Integer
Dim oFindRecord As _FindParams
With oFindRecord
.FindRecord = 0
.FindWhat = pvFindWhat
.Match = pvMatch
.MatchCase = pvMatchCase
.Search = pvSearch
.SearchAsFormatted = pvSearchAsFormatted
.FindFirst = pvFindFirst

' Determine target
' Either: pvTargetedField = Grid => search all fields
' pvTargetedField = Control in Grid => search only in that column
' pvTargetedField = acAll or acCurrent => determine focus
Select Case True

Case VarType(pvTargetedField) = vbString
Set ocTarget = getObject(pvTargetedField)

If ocTarget.SubType = CTLGRIDCONTROL Then
.OnlyCurrentField = acAll
.GridControl = ocTarget._Shortcut
.Target = .GridControl
ofParentForm = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name))
If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
iCount = -1
For i = 0 To ocTarget.ControlModel.Count - 1
Set vColumn = ocTarget.ControlModel.getByIndex(i)
Set vDataField = vColumn.BoundField ' examine field type
If Not IsNull(vDataField) Then
If _CheckColumnType(pvFindWhat, vDataField) Then
iCount = iCount + 1
ReDim Preserve vNames(0 To iCount)
vNames(iCount) = vColumn.Name
ReDim Preserve vIndexes(0 To iCount)
For j = 0 To oColumns.Count - 1
If vDataField.Name = oColumns.ElementNames(j) Then
vIndexes(iCount) = j + 1
Exit For
End If
Next j
End If
End If
Next i

ElseIf ocTarget._Type = OBJCONTROL Then ' Control within a grid tbc
If IsNull(ocTarget.ControlModel.BoundField) Then Goto Error_Target ' Control MUST be bound to a database record or query
' BoundField is in ControlModel, thanks PASTIM !
.OnlyCurrentField = acCurrent
vParentGrid = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name))
If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target
.GridControl = vParentGrid._Shortcut
ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name))
If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola
If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
.Target = ocTarget._Shortcut
Set vDataField = ocTarget.ControlModel.BoundField
If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target
ReDim vNames(0), vIndexes(0)
vNames(0) = ocTarget._Name
Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
For j = 0 To oColumns.Count - 1
If vDataField.Name = oColumns.ElementNames(j) Then
vIndexes(0) = j + 1
Exit For
End If
Next j
End If

Case Else ' Determine focus
iCount = Application.Forms()._Count
If iCount = 0 Then Goto Error_ActiveForm
bFound = False
For i = 0 To iCount - 1 ' Determine form having the focus
Set ofParentForm = Application.Forms(i)
If ofParentForm.Component.CurrentController.Frame.IsActive() Then
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Error_ActiveForm
If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
iCount = ofParentForm.Controls().Count
bFound = False
For i = 0 To iCount - 1
Set ocGridControl = ofParentForm.Controls(i)
If ocGridControl.SubType = CTLGRIDCONTROL Then
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Error_NoGrid
.GridControl= ocGridControl._Shortcut
iFocus = -1
iFocus = ocGridControl.ControlView.getCurrentColumnPosition() ' Deprecated but no alternative found !!

If pvTargetedField = acAll Or iFocus < 0 Or iFocus >= ocGridControl.ControlModel.Count Then ' Has a control within the grid the focus ? NO
.OnlyCurrentField = acAll
Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
iCount = -1
For i = 0 To ocGridControl.ControlModel.Count - 1
Set vColumn = ocGridControl.ControlModel.getByIndex(i)
Set vDataField = vColumn.BoundField ' examine field type
If Not IsNull(vDataField) Then
If _CheckColumnType(pvFindWhat, vDataField) Then
iCount = iCount + 1
ReDim Preserve vNames(0 To iCount)
vNames(iCount) = vColumn.Name
ReDim Preserve vIndexes(0 To iCount)
For j = 0 To oColumns.Count - 1
If vDataField.Name = oColumns.ElementNames(j) Then
vIndexes(iCount) = j + 1
Exit For
End If
Next j
End If
End If
Next i

Else ' Has a control within the grid the focus ? YES
.OnlyCurrentField = acCurrent
Set vColumn = ocGridControl.ControlModel.getByIndex(iFocus)
Set ocTarget = ocGridControl.Controls(vColumn.Name)
.Target = ocTarget._Shortcut
Set vDataField = ocTarget.ControlModel.BoundField
If IsNull(vDataField) Then Goto Error_Target ' Control MUST be bound to a database record or query
If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target
ReDim vNames(0), vIndexes(0)
vNames(0) = ocTarget._Name
Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
For j = 0 To oColumns.Count - 1
If vDataField.Name = oColumns.ElementNames(j) Then
vIndexes(0) = j + 1
Exit For
End If
Next j
End If

End Select

.Form = ofParentForm._Shortcut
.LastColumn = UBound(vNames)
.ColumnNames = vNames
.ResultSetIndex = vIndexes
If pvFindFirst Then
Select Case pvSearch
Case acDown, acSearchAll
ofParentForm.DatabaseForm.beforeFirst()
.LastRow = 0
Case acUp
ofParentForm.DatabaseForm.afterLast()
.LastRow = ofParentForm.DatabaseForm.RowCount + 1
End Select
Else
Select Case True
Case ofParentForm.DatabaseForm.isBeforeFirst And (pvSearch = acSearchAll Or pvSearch = acDown)
.LastRow = 0
Case ofParentForm.DatabaseForm.isAfterLast And pvSearch = acUp
ofParentForm.DatabaseForm.last() ' RowCount produces a wrong value as long as last record has not been reached
.LastRow = ofParentForm.DatabaseForm.RowCount + 1
Case Else
.LastRow = ofParentForm.DatabaseForm.getRow()
End Select
End If

.FindRecord = 1

End With
Set _A2B_.FindRecord = oFindRecord
FindRecord = DoCmd.Findnext()

Exit_Function:
Utils._ResetCalledSub("FindRecord")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "FindRecord", Erl)
GoTo Exit_Function
Error_ActiveForm:
TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0)
Goto Exit_Function
Error_DatabaseForm:
TraceError(TRACEFATAL, ERRDATABASEFORM, Utils._CalledSub(), 0, 1, vParentForm._Name)
Goto Exit_Function
Error_Target:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(6, pvTargetedField))
Goto Exit_Function
Error_NoGrid:
TraceError(TRACEFATAL, ERRNOGRIDINFORM, Utils._CalledSub(), 0, 1, vParentForm._Name)
Goto Exit_Function
End Function ' FindRecord V1.1.0
Access2BaseDev DoCmd GetHiddenAttribute Basic   38
REM -----------------------------------------------------------------------------------------------------------------------
Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _
, ByVal Optional pvObjectName As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "GetHiddenAttribute"
Utils._SetCalledSub(cstThisSub)

If IsMissing(pvObjectType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _
) Then Goto Exit_Function
If IsMissing(pvObjectName) Then
Select Case pvObjectType
Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
Case Else
End Select
pvObjectName = ""
Else
If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
End If

Dim oWindow As Object
Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
If IsNull(oWindow.Frame) Then Goto Error_NotFound
GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible()

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' GetHiddenAttribute V1.1.0
Access2BaseDev DoCmd GoToControl Basic   38
REM -----------------------------------------------------------------------------------------------------------------------
Public Function GoToControl(Optional ByVal pvControlName As variant) As Boolean
' Set the focus on the named control on the active form.
' Return False if the control does not exist or is disabled,

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("GoToControl")
If IsMissing(pvControlName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function

GoToControl = False
Dim oWindow As Object, ofForm As Object, ocControl As Object
Dim i As Integer, iCount As Integer
Set oWindow = _SelectWindow()
If oWindow.WindowType = acForm Then
Set ofForm = Application.Forms(oWindow._Name)
iCount = ofForm.Controls().Count
For i = 0 To iCount - 1
ocControl = ofForm.Controls(i)
If UCase(ocControl._Name) = UCase(pvControlName) Then
If Methods.hasProperty(ocControl, "Enabled") Then
If ocControl.Enabled Then
ocControl.setFocus()
GoToControl = True
Exit For
End If
End If
End If
Next i
End If

Exit_Function:
Utils._ResetCalledSub("GoToControl")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "GoToControl", Erl)
GoTo Exit_Function
End Function ' GoToControl V0.9.0
Access2BaseDev DoCmd GoToRecord Basic   126
REM -----------------------------------------------------------------------------------------------------------------------
Public Function GoToRecord(Optional ByVal pvObjectType As Variant _
, Optional ByVal pvObjectName As Variant _
, Optional ByVal pvRecord As Variant _
, Optional ByVal pvOffset As Variant _
) As Boolean

'Move to record indicated by pvRecord/pvOffset in the window designated by pvObjectType and pvObjectName

If _ErrorHandler() Then On Local Error Goto Error_Function
GoToRecord = False

Const cstThisSub = "GoTorecord"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvObjectName) Then pvObjectName = ""
If IsMissing(pvObjectType) Then pvObjectType = acActiveDataObject
If IsMissing(pvRecord) Then pvRecord = acNext
If IsMissing(pvOffset) Then pvOffset = 1
If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _
, Array(acActiveDataObject, acDataForm, acDataQuery, acDataTable)) _
And Utils._CheckArgument(pvObjectName, 2, vbString) _
And Utils._CheckArgument(pvRecord, 3, Utils._AddNumeric() _
, Array(acFirst, acGoTo, acLast, acNewRec, acNext, acPrevious)) _
And Utils._CheckArgument(pvOffset, 4, Utils._AddNumeric()) _
) Then Goto Exit_Function
If pvObjectType = acActiveDataObject And pvObjectName <> "" Then Goto Error_Target
If pvOffset < 0 And pvRecord <> acGoTo Then Goto Error_Offset

Dim ofForm As Object, oGeneric As Object, oResultSet As Object, oWindow As Object
Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long
Dim sObjectName, iLengthName As Integer
Select Case pvObjectType
Case acActiveDataObject
Set oWindow = _SelectWindow()
With oWindow
Select Case .WindowType
Case acForm
Set oResultSet = _DatabaseForm(._Name, "")
Case acQuery, acTable
If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
' FormOperations returns <Null> in OpenOffice
Set oResultSet = .Frame.Controller.FormOperations.Cursor
Case Else ' Ignore action
Goto Exit_Function
End Select
End With
Case acDataForm
' pvObjectName can be "myForm", "Forms!myForm", "Forms!myForm!mySubform" or "Forms!myForm!mySubform.Form"
sObjectName = UCase(pvObjectName)
iLengthName = Len(sObjectName)
Select Case True
Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" And Right(sObjectName, 5) = ".FORM"
Set ofForm = getObject(pvObjectName)
If ofForm._Type <> OBJSUBFORM Then Goto Error_Target
Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!"
Set oGeneric = getObject(pvObjectName)
If oGeneric._Type = OBJFORM Or oGeneric._Type = OBJSUBFORM Then
Set ofForm = oGeneric
ElseIf oGeneric.SubType = CTLSUBFORM Then
Set ofForm = oGeneric.Form
Else Goto Error_Target
End If
Case sObjectName = ""
Call _TraceArguments()
Case Else
Set ofForm = Application.Forms(pvObjectName)
End Select
Set oResultSet = ofForm.DatabaseForm
Case acDataQuery
Set oWindow = _SelectWindow(acQuery, pvObjectName)
If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
' FormOperations returns <Null> in OpenOffice
Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor
Case acDataTable
Set oWindow = _SelectWindow(acTable, pvObjectName)
If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor
Case Else
End Select

' Check if current row updated => Save it
If oResultSet.IsNew Then
oResultSet.insertRow()
ElseIf oResultSet.IsModified Then
oResultSet.updateRow()
End If

lOffset = pvOffset
Select Case pvRecord
Case acFirst : GoToRecord = oResultSet.first()
Case acGoTo : GoToRecord = oResultSet.absolute(lOffset)
Case acLast : GoToRecord = oResultSet.last()
Case acNewRec
oResultSet.last() ' To simulate the behaviour in the UI
oResultSet.moveToInsertRow()
GoToRecord = True
Case acNext
If lOffset = 1 Then
GoToRecord = oResultSet.next()
Else
GoToRecord = oResultSet.relative(lOffset)
End If
Case acPrevious
If lOffset = 1 Then
GoToRecord = oResultSet.previous()
Else
GoToRecord = oResultSet.relative(- lOffset)
End If
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_Target:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(2, pvObjectName))
Goto Exit_Function
Error_Offset:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(4, pvOffset))
Goto Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' GoToRecord
Access2BaseDev DoCmd Maximize Basic   16
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Maximize() As Boolean
' Maximize the window having the focus
Utils._SetCalledSub("Maximize")

Dim oWindow As Object
Maximize = False
Set oWindow = _SelectWindow()
If Not IsNull(oWindow.Frame) Then
If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMaximized") Then oWindow.Frame.ContainerWindow.IsMaximized = True ' Ignored when <= OO3.2
Maximize = True
End If

Utils._ResetCalledSub("Maximize")
Exit Function
End Function ' Maximize V0.8.5
Access2BaseDev DoCmd mClose Basic   82
REM -----------------------------------------------------------------------------------------------------------------------
Public Function mClose(Optional ByVal pvObjectType As Variant _
, Optional ByVal pvObjectName As Variant _
, Optional ByVal pvSave As Variant _
) As Boolean
If _ErrorHandler() Then On Local Error Goto Error_Function

Const cstThisSub = "Close"
Utils._SetCalledSub(cstThisSub)
mClose = False
If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments()
If IsMissing(pvSave) Then pvSave = acSavePrompt
If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
Array(acTable, acQuery, acForm, acReport)) _
And Utils._CheckArgument(pvObjectName, 2, vbString) _
And Utils._CheckArgument(pvSave, 3, Utils._AddNumeric(), Array(acSavePrompt)) _
) Then Goto Exit_Function

Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object
Dim i As Integer, bFound As Boolean, lComponent As Long
Dim oDatabase As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

' Check existence of object and find its exact (case-sensitive) name
Select Case pvObjectType
Case acForm
sObjects = oDatabase.Document.getFormDocuments.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.FORM
Case acTable
sObjects = oDatabase.Connection.getTables.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE
Case acQuery
sObjects = oDatabase.Connection.getQueries.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY
Case acReport
sObjects = oDatabase.Document.getReportDocuments.ElementNames()
lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT
End Select
bFound = False
For i = 0 To UBound(sObjects)
If UCase(pvObjectName) = UCase(sObjects(i)) Then
sObjectName = sObjects(i)
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound

Select Case pvObjectType
Case acForm
Set oController = oDatabase.Document.getFormDocuments.getByName(sObjectName)
mClose = oController.close()
Case acTable, acQuery ' Not optimal but it works !!
Set oController = oDatabase.Document.CurrentController
Set oObject = oController.loadComponent(lComponent, sObjectName, False)
oObject.frame.close(False)
mClose = True
Case acReport
Set oController = oDatabase.Document.getReportDocuments.getByName(sObjectName)
mClose = oController.close()
End Select


Exit_Function:
Set oObject = Nothing
Set oController = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Close", Erl)
GoTo Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERRCLOSEOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName))
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName))
Goto Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' (m)Close V1.1.0
Access2BaseDev DoCmd Minimize Basic   16
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Minimize() As Boolean
' Maximize the form having the focus
Utils._SetCalledSub("Minimize")

Dim oWindow As Object
Minimize = False
Set oWindow = _SelectWindow()
If Not IsNull(oWindow.Frame) Then
If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMinimized") Then oWindow.Frame.ContainerWindow.IsMinimized = True
Minimize = True
End If

Utils._ResetCalledSub("Minimize")
Exit Function
End Function ' Minimize V0.8.5
Access2BaseDev DoCmd MoveSize Basic   62
REM -----------------------------------------------------------------------------------------------------------------------
Public Function MoveSize(ByVal Optional pvLeft As Variant _
, ByVal Optional pvTop As Variant _
, ByVal Optional pvWidth As Variant _
, ByVal Optional pvHeight As Variant _
) As Variant
' Execute MoveSize action
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("MoveSize")
MoveSize = False
If IsMissing(pvLeft) Then pvLeft = -1
If IsMissing(pvTop) Then pvTop = -1
If IsMissing(pvWidth) Then pvWidth = -1
If IsMissing(pvHeight) Then pvHeight = -1
If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function

Dim iArg As Integer, iWrong As Integer ' Check arguments values
iArg = 0
If pvHeight < -1 Then
iArg = 4 : iWrong = pvHeight
ElseIf pvWidth < -1 Then
iArg = 3 : iWrong = pvWidth
ElseIf pvTop < -1 Then
iArg = 2 : iWrong = pvTop
ElseIf pvLeft < -1 Then
iArg = 1 : iWrong = pvLeft
End If
If iArg > 0 Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArg, iWrong))
Goto Exit_Function
End If

Dim iPosSize As Integer
iPosSize = 0
If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X
If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y
If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH
If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT

Dim oWindow As Object
Set oWindow = _SelectWindow()
With oWindow
If Not IsNull(.Frame) Then
If Utils._hasUNOProperty(.Frame.ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2
.Frame.ContainerWindow.IsMaximized = False
.Frame.ContainerWindow.IsMinimized = False
End If
.Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize)
MoveSize = True
End If
End With

Exit_Function:
Utils._ResetCalledSub("MoveSize")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "MoveSize", Erl)
GoTo Exit_Function
End Function ' MoveSize V1.1.0
Access2BaseDev DoCmd OpenForm Basic Quit (Procedure) 117
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenForm(Optional ByVal pvFormName As Variant _
, Optional ByVal pvView As Variant _
, Optional ByVal pvFilterName As Variant _
, Optional ByVal pvWhereCondition As Variant _
, Optional ByVal pvDataMode As Variant _
, Optional ByVal pvWindowMode As Variant _
, Optional ByVal pvOpenArgs As Variant _
) As Variant

If _ErrorHandler() Then On Local Error Goto Error_Function

Utils._SetCalledSub("OpenForm")
If IsMissing(pvFormName) Then Call _TraceArguments()
If IsMissing(pvView) Then pvView = acNormal
If IsMissing(pvFilterName) Then pvFilterName = ""
If IsMissing(pvWhereCondition) Then pvWhereCondition = ""
If IsMissing(pvDataMode) Then pvDataMode = acFormPropertySettings
If IsMissing(pvWindowMode) Then pvWindowMode = acWindowNormal
If IsMissing(pvOpenArgs) Then pvOpenArgs = ""
Set OpenForm = Nothing
If Not (Utils._CheckArgument(pvFormName, 1, vbString) _
And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acNormal, acPreview, acDesign)) _
And Utils._CheckArgument(pvFilterName, 3, vbString) _
And Utils._CheckArgument(pvWhereCondition, 4, vbString) _
And Utils._CheckArgument(pvDataMode, 5, Utils._AddNumeric(), Array(acFormAdd, acFormEdit, acFormPropertySettings, acFormReadOnly)) _
And Utils._CheckArgument(pvWindowMode, 6, Utils._AddNumeric(), Array(acDialog, acHidden, acIcon, acWindowNormal)) _
) Then Goto Exit_Function

Dim ofForm As Object, sWarning As String
Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object

Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

Set ofForm = Application.AllForms(pvFormName)
If ofForm.IsLoaded Then
sWarning = _GetLabel("ERR" & ERRFORMYETOPEN)
sWarning = Join(Split(sWarning, "%0"), ofForm._Name)
TraceLog(TRACEANY, "OpenForm: " & sWarning)
Set OpenForm = ofForm
Goto Exit_Function
End If
' Open the form
Select Case pvView
Case acNormal, acPreview: bOpenMode = False
Case acDesign : bOpenMode = True
End Select
Set oController = oDatabase.Document.CurrentController
Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode)

' Apply the filters (FilterName) AND (WhereCondition)
Dim sFilter As String, oForm As Object, oFormsCollection As Object
If pvFilterName = "" And pvWhereCondition = "" Then
sFilter = ""
ElseIf pvFilterName = "" Or pvWhereCondition = "" Then
sFilter = pvFilterName & pvWhereCondition
Else
sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")"
End If
If Not IsNull(oForm) Then
If sFilter <> "" Then
oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter)
oForm.ApplyFilter = True
oForm.reload()
ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed
oForm.Filter = ""
oForm.ApplyFilter = False
oForm.reload()
End If
End If

'Housekeeping
Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open
With ofForm
If Not IsNull(.DatabaseForm) Then
Select Case pvDataMode
Case acFormAdd
.AllowAdditions = True
.AllowDeletions = False
.AllowEdits = False
Case acFormEdit
.AllowAdditions = True
.AllowDeletions = True
.AllowEdits = True
Case acFormReadOnly
.AllowAdditions = False
.AllowDeletions = False
.AllowEdits = False
Case acFormPropertySettings
End Select
End If
.Visible = ( pvWindowMode <> acHidden )
._OpenArgs = pvOpenArgs
'To avoid AOO 3,4 bug See http://user.services.openoffice.org/en/forum/viewtopic.php?f=13&t=53751
.Component.CurrentController.ViewSettings.ShowOnlineLayout = True
End With

Set OpenForm = ofForm

Exit_Function:
Utils._ResetCalledSub("OpenForm")
Set ofForm = Nothing
Set oOpenForm = Nothing
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenForm", Erl)
Set OpenForm = Nothing
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1)
Goto Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName)
Set OpenForm = Nothing
Goto Exit_Function
End Function ' OpenForm V0.9.0
Access2BaseDev DoCmd OpenQuery Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenQuery(Optional ByVal pvQueryName As Variant _
, Optional ByVal pvView As Variant _
, Optional ByVal pvDataMode As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function

Utils._SetCalledSub("OpenQuery")
If IsMissing(pvQueryName) Then Call _TraceArguments()
If IsMissing(pvView) Then pvView = acViewNormal
If IsMissing(pvDataMode) Then pvDataMode = acEdit
OpenQuery = DoCmd._OpenObject("Query", pvQueryName, pvView, pvDataMode)

Exit_Function:
Utils._ResetCalledSub("OpenQuery")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenQuery", Erl)
GoTo Exit_Function
End Function ' OpenQuery
Access2BaseDev DoCmd OpenReport Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenReport(Optional ByVal pvReportName As Variant _
, Optional ByVal pvView As Variant _
, Optional ByVal pvDataMode As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function

Utils._SetCalledSub("OpenReport")
If IsMissing(pvReportName) Then Call _TraceArguments()
If IsMissing(pvView) Then pvView = acViewNormal
If IsMissing(pvDataMode) Then pvDataMode = acEdit
OpenReport = DoCmd._OpenObject("Report", pvReportName, pvView, pvDataMode)

Exit_Function:
Utils._ResetCalledSub("OpenReport")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenReport", Erl)
GoTo Exit_Function
End Function ' OpenReport
Access2BaseDev DoCmd OpenSQL Basic   31
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenSQL(Optional ByVal pvSQL As Variant _
, Optional ByVal pvOption As Variant _
) As Boolean
' Return True if the execution of the SQL statement was successful
' SQL must contain a SELECT query
' pvOption can force pass through mode

If _ErrorHandler() Then On Local Error Goto Error_Function

Utils._SetCalledSub("OpenSQL")

OpenSQL = False
If IsMissing(pvSQL) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
Const cstNull = -1
If IsMissing(pvOption) Then
pvOption = cstNull
Else
If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
End If

OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption)

Exit_Function:
Utils._ResetCalledSub("OpenSQL")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenSQL", Erl)
GoTo Exit_Function
End Function ' OpenSQL V1.1.0
Access2BaseDev DoCmd OpenTable Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenTable(Optional ByVal pvTableName As Variant _
, Optional ByVal pvView As Variant _
, Optional ByVal pvDataMode As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function

Utils._SetCalledSub("OpenTable")
If IsMissing(pvTableName) Then Call _TraceArguments()
If IsMissing(pvView) Then pvView = acViewNormal
If IsMissing(pvDataMode) Then pvDataMode = acEdit
OpenTable = DoCmd._OpenObject("Table", pvTableName, pvView, pvDataMode)

Exit_Function:
Utils._ResetCalledSub("OpenTable")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "OpenTable", Erl)
GoTo Exit_Function
End Function ' OpenTable
Access2BaseDev DoCmd OutputTo Basic SendObject (Procedure) 146
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OutputTo(ByVal pvObjectType As Variant _
, ByVal Optional pvObjectName As Variant _
, ByVal Optional pvOutputFormat As Variant _
, ByVal Optional pvOutputFile As Variant _
, ByVal Optional pvAutoStart As Variant _
, ByVal Optional pvTemplateFile As Variant _
, ByVal Optional pvEncoding As Variant _
, ByVal Optional pvQuality As Variant _
) As Boolean
REM https://wiki.openoffice.org/wiki/Framework/Article/Filter/FilterList_OOo_3_0
REM https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options
REM https://msdn.microsoft.com/en-us/library/ms709353%28v=vs.85%29.aspx
'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms
' acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "OutputTo"
Utils._SetCalledSub(cstThisSub)

OutputTo = False

If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputForm)) Then Goto Exit_Function
If IsMissing(pvObjectName) Then pvObjectName = ""
If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
If pvOutputFormat <> "" Then
If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _
, UCase(acFormatODS), UCase(acFormatXLS), UCase(acFormatXLSX), UCase(acFormatTXT) _
, "PDF", "ODT", "DOC", "HTML", "ODS", "XLS", "XLSX", "TXT", "CSV", "" _
)) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity
End If
If IsMissing(pvOutputFile) Then pvOutputFile = ""
If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
If IsMissing(pvAutoStart) Then pvAutoStart = False
If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function
If IsMissing(pvEncoding) Then pvEncoding = 0
If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function
If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function

If pvObjectType = acOutputTable Or pvObjectType = acOutputQuery Then
OutputTo = Application._CurrentDb().OutputTo( _
pvObjectType _
, pvObjectName _
, pvOutputFormat _
, pvOutputFile _
, pvAutoStart _
, pvTemplateFile _
, pvEncoding _
, pvQuality _
)
GoTo Exit_Function
End If

Dim vWindow As Variant, sOutputFile As String, ofForm As Object, i As Integer, bFound As Boolean
'Find applicable form
If pvObjectName = "" Then
vWindow = _SelectWindow()
If vWindow.WindowType <> acOutoutForm Then Goto Error_Action
Set ofForm = Application.Forms(vWindow._Name)
Else
bFound = False
For i = 0 To Application.Forms()._Count - 1
Set ofForm = Application.Forms(i)
If UCase(ofForm._Name) = UCase(pvObjectName) Then
bFound = True
Exit For
End If
Next i
If Not bFound Then Goto Error_NotFound
End If

'Determine format and parameters
Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport As Object, sSuffix As String
If pvOutputFormat = "" Then
sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format
If sOutputFormat = "" Then Goto Exit_Function
Else
sOutputFormat = UCase(pvOutputFormat)
End If
Select Case sOutputFormat
Case UCase(acFormatPDF), "PDF"
sFilter = acFormatPDF
oFilterData = Array( _
_MakePropertyValue ("ExportFormFields", False), _
)
sSuffix = "pdf"
Case UCase(acFormatDOC), "DOC"
sFilter = acFormatDOC
oFilterData = Array()
sSuffix = "doc"
Case UCase(acFormatODT), "ODT"
sFilter = acFormatODT
oFilterData = Array()
sSuffix = "odt"
Case UCase(acFormatHTML), "HTML"
sFilter = acFormatHTML
oFilterData = Array()
sSuffix = "html"
End Select
oExport = Array( _
_MakePropertyValue("Overwrite", True), _
_MakePropertyValue("FilterName", sFilter), _
_MakePropertyValue("FilterData", oFilterData), _
)

'Determine output file
If pvOutputFile = "" Then ' Prompt file picker to user
sOutputFile = _PromptFilePicker(sSuffix)
If sOutputFile = "" Then Goto Exit_Function
Else
sOutputFile = pvOutputFile
End If
sOutputFile = ConvertToURL(sOutputFile)

'Create file
On Local Error Goto Error_File
ofForm.Component.storeToURL(sOutputFile, oExport)
On Local Error Goto Error_Function

'Launch application, if requested
If pvAutoStart Then Call _ShellExecute(sOutputFile)

OutputTo = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
Goto Exit_Function
Error_Action:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_File:
TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
GoTo Exit_Function
End Function ' OutputTo V0.9.1
Access2BaseDev DoCmd Quit Basic   51
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Quit(Optional ByVal pvSave As Variant) As Variant
' Quit the application
' Modified from Andrew Pitonyak's Base Macro Programming §5.8.1

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Quit"
Utils._SetCalledSub(cstThisSub)

If IsMissing(pvSave) Then pvSave = acQuitSaveAll
If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _
Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _
) Then Goto Exit_Function

Dim oDatabase As Object, oDoc As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
If Not IsNull(oDatabase) Then
Set oDoc = oDatabase.Document
Select Case pvSave
Case acQuitPrompt
If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function
Case acQuitSaveNone
oDoc.setModified(False)
Case Else
End Select
If HasUnoInterfaces(oDoc, "com.sun.star.util.XCloseable") Then
If (oDoc.isModified) Then
If (oDoc.hasLocation AND (Not oDoc.isReadOnly)) Then
oDoc.store()
End If
End If
oDoc.close(true)
Else
oDoc.dispose()
End If
End If

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Set oDatabase = Nothing
Set oDoc = Nothing
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
Set OpenForm = Nothing
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' Quit V1.1.0
Access2BaseDev DoCmd RunApp Basic   20
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub RunApp(Optional ByVal pvCommandLine As Variant)
' Convert to URL and execute the Command Line

If _ErrorHandler() Then On Local Error Goto Error_Sub

Utils._SetCalledSub("RunApp")

If IsMissing(pvCommandLine) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub

_ShellExecute(ConvertToURL(pvCommandLine))

Exit_Sub:
Utils._ResetCalledSub("RunApp")
Exit Sub
Error_Sub:
TraceError(TRACEABORT, Err, "RunApp", Erl)
GoTo Exit_Sub
End Sub ' RunApp V0.8.5
Access2BaseDev DoCmd RunCommand Basic ShowAllrecords (Procedure)
Execute (Procedure)
_PropertySet (Procedure)
218
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RunCommand(Optional pvCommand As Variant, Optional pbReturnCommand As Boolean) As Variant
' Execute command via DispatchHelper
' pbReturnCommand = internal parameter to only return the exact command string (always absent if uno prefix present in pvCommand)

If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort
Const cstThisSub = "RunCommand"
Utils._SetCalledSub(cstThisSub)

Dim iVBACommand As Integer, sOOCommand As String, sDispatch As String
If IsMissing(pvCommand) Then Call _TraceArguments()
If Not ( Utils._CheckArgument(pvCommand, 1, Utils._AddNumeric(vbString)) ) Then Goto Exit_Function
If IsMissing(pbReturnCommand) Then pbReturnCommand = False

RunCommand = True

Const cstUnoPrefix = ".uno:"
If VarType(pvCommand) = vbString Then
sOOCommand = pvCommand
iVBACommand = -1
If _IsLeft(sOOCommand, cstUnoPrefix) Then
Call _DispatchCommand(sOOCommand)
Goto Exit_Function
End If
Else
sOOCommand = ""
iVBACommand = pvCommand
End If

Select Case True
Case iVBACommand = acCmdAboutMicrosoftAccess Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
Case iVBACommand = acCmdAboutOpenOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
Case iVBACommand = acCmdAboutLibreOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
Case UCase(sOOCommand) = "ACTIVEHELP" : sDispatch = "ActiveHelp"
Case UCase(sOOCommand) = "ADDDIRECT" : sDispatch = "AddDirect"
Case UCase(sOOCommand) = "ADDFIELD" : sDispatch = "AddField"
Case UCase(sOOCommand) = "AUTOCONTROLFOCUS" : sDispatch = "AutoControlFocus"
Case UCase(sOOCommand) = "AUTOFILTER" : sDispatch = "AutoFilter"
Case UCase(sOOCommand) = "AUTOPILOTADDRESSDATASOURCE" : sDispatch = "AutoPilotAddressDataSource"
Case UCase(sOOCommand) = "BASICBREAK" : sDispatch = "BasicBreak"
Case iVBACommand = acCmdVisualBasicEditor Or UCase(sOOCommand) = "BASICIDEAPPEAR" : sDispatch = "BasicIDEAppear"
Case UCase(sOOCommand) = "BASICSTOP" : sDispatch = "BasicStop"
Case iVBACommand = acCmdBringToFront Or UCase(sOOCommand) = "BRINGTOFRONT" : sDispatch = "BringToFront"
Case UCase(sOOCommand) = "CHECKBOX" : sDispatch = "CheckBox"
Case UCase(sOOCommand) = "CHOOSEMACRO" : sDispatch = "ChooseMacro"
Case iVBACommand = acCmdClose Or UCase(sOOCommand) = "CLOSEDOC" : sDispatch = "CloseDoc"
Case UCase(sOOCommand) = "CLOSEWIN" : sDispatch = "CloseWin"
Case iVBACommand = acCmdToolbarsCustomize Or UCase(sOOCommand) = "CONFIGUREDIALOG" : sDispatch = "ConfigureDialog"
Case UCase(sOOCommand) = "CONTROLPROPERTIES" : sDispatch = "ControlProperties"
Case iVBACommand = acCmdChangeToCommandButton Or UCase(sOOCommand) = "CONVERTTOBUTTON" : sDispatch = "ConvertToButton"
Case iVBACommand = acCmdChangeToCheckBox Or UCase(sOOCommand) = "CONVERTTOCHECKBOX" : sDispatch = "ConvertToCheckBox"
Case iVBACommand = acCmdChangeToComboBox Or UCase(sOOCommand) = "CONVERTTOCOMBO" : sDispatch = "ConvertToCombo"
Case UCase(sOOCommand) = "CONVERTTOCURRENCY" : sDispatch = "ConvertToCurrency"
Case UCase(sOOCommand) = "CONVERTTODATE" : sDispatch = "ConvertToDate"
Case iVBACommand = acCmdChangeToTextBox Or UCase(sOOCommand) = "CONVERTTOEDIT" : sDispatch = "ConvertToEdit"
Case UCase(sOOCommand) = "CONVERTTOFILECONTROL" : sDispatch = "ConvertToFileControl"
Case iVBACommand = acCmdChangeToLabel Or UCase(sOOCommand) = "CONVERTTOFIXED" : sDispatch = "ConvertToFixed"
Case UCase(sOOCommand) = "CONVERTTOFORMATTED" : sDispatch = "ConvertToFormatted"
Case UCase(sOOCommand) = "CONVERTTOGROUP" : sDispatch = "ConvertToGroup"
Case UCase(sOOCommand) = "CONVERTTOIMAGEBTN" : sDispatch = "ConvertToImageBtn"
Case iVBACommand = acCmdChangeToImage Or UCase(sOOCommand) = "CONVERTTOIMAGECONTROL" : sDispatch = "ConvertToImageControl"
Case iVBACommand = acCmdChangeToListBox Or UCase(sOOCommand) = "CONVERTTOLIST" : sDispatch = "ConvertToList"
Case UCase(sOOCommand) = "CONVERTTONAVIGATIONBAR" : sDispatch = "ConvertToNavigationBar"
Case UCase(sOOCommand) = "CONVERTTONUMERIC" : sDispatch = "ConvertToNumeric"
Case UCase(sOOCommand) = "CONVERTTOPATTERN" : sDispatch = "ConvertToPattern"
Case iVBACommand = acCmdChangeToOptionButton Or UCase(sOOCommand) = "CONVERTTORADIO" : sDispatch = "ConvertToRadio"
Case UCase(sOOCommand) = "CONVERTTOSCROLLBAR" : sDispatch = "ConvertToScrollBar"
Case UCase(sOOCommand) = "CONVERTTOSPINBUTTON" : sDispatch = "ConvertToSpinButton"
Case UCase(sOOCommand) = "CONVERTTOTIME" : sDispatch = "ConvertToTime"
Case iVBACommand = acCmdCopy Or UCase(sOOCommand) = "COPY" : sDispatch = "Copy"
Case UCase(sOOCommand) = "CURRENCYFIELD" : sDispatch = "CurrencyField"
Case iVBACommand = acCmdCut Or UCase(sOOCommand) = "CUT" : sDispatch = "Cut"
Case UCase(sOOCommand) = "DATEFIELD" : sDispatch = "DateField"
Case iVBACommand = acCmdCreateRelationship Or UCase(sOOCommand) = "DBADDRELATION " : sDispatch = "DBAddRelation "
Case UCase(sOOCommand) = "DBCONVERTTOVIEW " : sDispatch = "DBConvertToView "
Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DBDELETE " : sDispatch = "DBDelete "
Case UCase(sOOCommand) = "DBDIRECTSQL " : sDispatch = "DBDirectSQL "
Case UCase(sOOCommand) = "DBDSADVANCEDSETTINGS " : sDispatch = "DBDSAdvancedSettings "
Case UCase(sOOCommand) = "DBDSCONNECTIONTYPE " : sDispatch = "DBDSConnectionType "
Case iVBACommand = acCmdDatabaseProperties Or UCase(sOOCommand) = "DBDSPROPERTIES " : sDispatch = "DBDSProperties "
Case UCase(sOOCommand) = "DBEDIT " : sDispatch = "DBEdit "
Case iVBACommand = acCmdSQLView Or UCase(sOOCommand) = "DBEDITSQLVIEW " : sDispatch = "DBEditSqlView "
Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBFORMDELETE " : sDispatch = "DBFormDelete "
Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBFORMEDIT " : sDispatch = "DBFormEdit "
Case iVBACommand = acCmdFormView Or UCase(sOOCommand) = "DBFORMOPEN " : sDispatch = "DBFormOpen "
Case UCase(sOOCommand) = "DBFORMRENAME " : sDispatch = "DBFormRename "
Case iVBACommand = acCmdNewObjectForm Or UCase(sOOCommand) = "DBNEWFORM " : sDispatch = "DBNewForm "
Case UCase(sOOCommand) = "DBNEWFORMAUTOPILOT " : sDispatch = "DBNewFormAutoPilot "
Case UCase(sOOCommand) = "DBNEWQUERY " : sDispatch = "DBNewQuery "
Case UCase(sOOCommand) = "DBNEWQUERYAUTOPILOT " : sDispatch = "DBNewQueryAutoPilot "
Case UCase(sOOCommand) = "DBNEWQUERYSQL " : sDispatch = "DBNewQuerySql "
Case UCase(sOOCommand) = "DBNEWREPORT " : sDispatch = "DBNewReport "
Case UCase(sOOCommand) = "DBNEWREPORTAUTOPILOT " : sDispatch = "DBNewReportAutoPilot "
Case iVBACommand = acCmdNewObjectTable Or UCase(sOOCommand) = "DBNEWTABLE " : sDispatch = "DBNewTable "
Case UCase(sOOCommand) = "DBNEWTABLEAUTOPILOT " : sDispatch = "DBNewTableAutoPilot "
Case iVBACommand = acCmdNewObjectView Or UCase(sOOCommand) = "DBNEWVIEW " : sDispatch = "DBNewView "
Case UCase(sOOCommand) = "DBNEWVIEWSQL " : sDispatch = "DBNewViewSQL "
Case iVBACommand = acCmdOpenDatabase Or UCase(sOOCommand) = "DBOPEN " : sDispatch = "DBOpen "
Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBQUERYDELETE " : sDispatch = "DBQueryDelete "
Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBQUERYEDIT " : sDispatch = "DBQueryEdit "
Case iVBACommand = acCmdNewObjectQuery Or UCase(sOOCommand) = "DBQUERYOPEN " : sDispatch = "DBQueryOpen "
Case UCase(sOOCommand) = "DBQUERYRENAME " : sDispatch = "DBQueryRename "
Case UCase(sOOCommand) = "DBREFRESHTABLES " : sDispatch = "DBRefreshTables "
Case iVBACommand = acCmdShowAllRelationships Or UCase(sOOCommand) = "DBRELATIONDESIGN " : sDispatch = "DBRelationDesign "
Case UCase(sOOCommand) = "DBRENAME " : sDispatch = "DBRename "
Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBREPORTDELETE " : sDispatch = "DBReportDelete "
Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBREPORTEDIT " : sDispatch = "DBReportEdit "
Case iVBACommand = acCmdNewObjectReport Or UCase(sOOCommand) = "DBREPORTOPEN " : sDispatch = "DBReportOpen "
Case UCase(sOOCommand) = "DBREPORTRENAME " : sDispatch = "DBReportRename "
Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "DBSELECTALL " : sDispatch = "DBSelectAll "
Case UCase(sOOCommand) = "DBSHOWDOCINFOPREVIEW " : sDispatch = "DBShowDocInfoPreview "
Case UCase(sOOCommand) = "DBSHOWDOCPREVIEW " : sDispatch = "DBShowDocPreview "
Case iVBACommand = acCmdRemoveTable Or UCase(sOOCommand) = "DBTABLEDELETE " : sDispatch = "DBTableDelete "
Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBTABLEEDIT " : sDispatch = "DBTableEdit "
Case UCase(sOOCommand) = "DBTABLEFILTER " : sDispatch = "DBTableFilter "
Case iVBACommand = acCmdOpenTable Or UCase(sOOCommand) = "DBTABLEOPEN " : sDispatch = "DBTableOpen "
Case iVBACommand = acCmdRename Or UCase(sOOCommand) = "DBTABLERENAME " : sDispatch = "DBTableRename "
Case UCase(sOOCommand) = "DBUSERADMIN " : sDispatch = "DBUserAdmin "
Case UCase(sOOCommand) = "DBVIEWFORMS " : sDispatch = "DBViewForms "
Case UCase(sOOCommand) = "DBVIEWQUERIES " : sDispatch = "DBViewQueries "
Case UCase(sOOCommand) = "DBVIEWREPORTS " : sDispatch = "DBViewReports "
Case UCase(sOOCommand) = "DBVIEWTABLES " : sDispatch = "DBViewTables "
Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DELETE" : sDispatch = "Delete"
Case iVBACommand = acCmdDeleteRecord Or UCase(sOOCommand) = "DELETERECORD" : sDispatch = "DeleteRecord"
Case UCase(sOOCommand) = "DESIGNERDIALOG" : sDispatch = "DesignerDialog"
Case UCase(sOOCommand) = "EDIT" : sDispatch = "Edit"
Case UCase(sOOCommand) = "FIRSTRECORD" : sDispatch = "FirstRecord"
Case UCase(sOOCommand) = "FONTDIALOG" : sDispatch = "FontDialog"
Case UCase(sOOCommand) = "FONTHEIGHT" : sDispatch = "FontHeight"
Case UCase(sOOCommand) = "FORMATTEDFIELD" : sDispatch = "FormattedField"
Case UCase(sOOCommand) = "FORMFILTER" : sDispatch = "FormFilter"
Case iVBACommand = acCmdApplyFilterSort Or UCase(sOOCommand) = "FORMFILTERED" : sDispatch = "FormFiltered"
Case UCase(sOOCommand) = "FORMFILTEREXECUTE" : sDispatch = "FormFilterExecute"
Case UCase(sOOCommand) = "FORMFILTEREXIT" : sDispatch = "FormFilterExit"
Case UCase(sOOCommand) = "FORMFILTERNAVIGATOR" : sDispatch = "FormFilterNavigator"
Case UCase(sOOCommand) = "FORMPROPERTIES" : sDispatch = "FormProperties"
Case UCase(sOOCommand) = "FULLSCREEN" : sDispatch = "FullScreen"
Case UCase(sOOCommand) = "GALLERY" : sDispatch = "Gallery"
Case UCase(sOOCommand) = "GRID" : sDispatch = "Grid"
Case iVBACommand = acCmdSnapToGrid Or UCase(sOOCommand) = "GRIDUSE" : sDispatch = "GridUse"
Case iVBACommand = acCmdViewGrid Or UCase(sOOCommand) = "GRIDVISIBLE" : sDispatch = "GridVisible"
Case UCase(sOOCommand) = "GROUPBOX" : sDispatch = "GroupBox"
Case UCase(sOOCommand) = "HELPINDEX" : sDispatch = "HelpIndex"
Case UCase(sOOCommand) = "HELPSUPPORT" : sDispatch = "HelpSupport"
Case iVBACommand = acCmdInsertHyperlink Or UCase(sOOCommand) = "HYPERLINKDIALOG" : sDispatch = "HyperlinkDialog"
Case UCase(sOOCommand) = "IMAGEBUTTON" : sDispatch = "Imagebutton"
Case UCase(sOOCommand) = "IMAGECONTROL" : sDispatch = "ImageControl"
Case UCase(sOOCommand) = "LABEL" : sDispatch = "Label"
Case iVBACommand = acCmdMaximumRecords Or UCase(sOOCommand) = "LASTRECORD" : sDispatch = "LastRecord"
Case UCase(sOOCommand) = "LISTBOX" : sDispatch = "ListBox"
Case UCase(sOOCommand) = "MACRODIALOG" : sDispatch = "MacroDialog"
Case UCase(sOOCommand) = "MACROORGANIZER" : sDispatch = "MacroOrganizer"
Case UCase(sOOCommand) = "MORECONTROLS" : sDispatch = "MoreControls"
Case UCase(sOOCommand) = "NAVIGATIONBAR" : sDispatch = "NavigationBar"
Case iVBACommand = acCmdObjectBrowser Or UCase(sOOCommand) = "NAVIGATOR" : sDispatch = "Navigator"
Case UCase(sOOCommand) = "NEWDOC" : sDispatch = "NewDoc"
Case UCase(sOOCommand) = "NEWRECORD" : sDispatch = "NewRecord"
Case UCase(sOOCommand) = "NEXTRECORD" : sDispatch = "NextRecord"
Case UCase(sOOCommand) = "NUMERICFIELD" : sDispatch = "NumericField"
Case UCase(sOOCommand) = "OPEN" : sDispatch = "Open"
Case UCase(sOOCommand) = "OPTIONSTREEDIALOG" : sDispatch = "OptionsTreeDialog"
Case UCase(sOOCommand) = "ORGANIZER" : sDispatch = "Organizer"
Case UCase(sOOCommand) = "PARAGRAPHDIALOG" : sDispatch = "ParagraphDialog"
Case iVBACommand = acCmdPaste Or UCase(sOOCommand) = "PASTE" : sDispatch = "Paste"
Case iVBACommand = acCmdPasteSpecial Or UCase(sOOCommand) = "PASTESPECIAL " : sDispatch = "PasteSpecial "
Case UCase(sOOCommand) = "PATTERNFIELD" : sDispatch = "PatternField"
Case UCase(sOOCommand) = "PREVRECORD" : sDispatch = "PrevRecord"
Case iVBACommand = acCmdPrint Or UCase(sOOCommand) = "PRINT" : sDispatch = "Print"
Case UCase(sOOCommand) = "PRINTDEFAULT" : sDispatch = "PrintDefault"
Case UCase(sOOCommand) = "PRINTERSETUP" : sDispatch = "PrinterSetup"
Case iVBACommand = acCmdPrintPreview Or UCase(sOOCommand) = "PRINTPREVIEW" : sDispatch = "PrintPreview"
Case UCase(sOOCommand) = "PUSHBUTTON" : sDispatch = "Pushbutton"
Case UCase(sOOCommand) = "QUIT" : sDispatch = "Quit"
Case UCase(sOOCommand) = "RADIOBUTTON" : sDispatch = "RadioButton"
Case iVBACommand = acCmdSaveRecord Or UCase(sOOCommand) = "RECSAVE" : sDispatch = "RecSave"
Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "RECSEARCH" : sDispatch = "RecSearch"
Case iVBACommand = acCmdUndo Or UCase(sOOCommand) = "RECUNDO" : sDispatch = "RecUndo"
Case iVBACommand = acCmdRefresh Or UCase(sOOCommand) = "REFRESH" : sDispatch = "Refresh"
Case UCase(sOOCommand) = "RELOAD" : sDispatch = "Reload"
Case iVBACommand = acCmdRemoveFilterSort Or UCase(sOOCommand) = "REMOVEFILTERSORT" : sDispatch = "RemoveFilterSort"
Case iVBACommand = acCmdRunMacro Or UCase(sOOCommand) = "RUNMACRO" : sDispatch = "RunMacro"
Case iVBACommand = acCmdSave Or UCase(sOOCommand) = "SAVE" : sDispatch = "Save"
Case UCase(sOOCommand) = "SAVEALL" : sDispatch = "SaveAll"
Case iVBACommand = acCmdSaveAs Or UCase(sOOCommand) = "SAVEAS" : sDispatch = "SaveAs"
Case UCase(sOOCommand) = "SAVEBASICAS" : sDispatch = "SaveBasicAs"
Case UCase(sOOCommand) = "SCRIPTORGANIZER" : sDispatch = "ScriptOrganizer"
Case UCase(sOOCommand) = "SCROLLBAR" : sDispatch = "ScrollBar"
Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "SEARCHDIALOG" : sDispatch = "SearchDialog"
Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll"
Case iVBACommand = acCmdSelectAllRecords Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll"
Case iVBACommand = acCmdSendToBack Or UCase(sOOCommand) = "SENDTOBACK" : sDispatch = "SendToBack"
Case UCase(sOOCommand) = "SHOWFMEXPLORER" : sDispatch = "ShowFmExplorer"
Case UCase(sOOCommand) = "SIDEBAR" : sDispatch = "Sidebar"
Case iVBACommand = acCmdSortDescending Or UCase(sOOCommand) = "SORTDOWN" : sDispatch = "SortDown"
Case iVBACommand = acCmdSortAscending Or UCase(sOOCommand) = "SORTUP" : sDispatch = "Sortup"
Case UCase(sOOCommand) = "SPINBUTTON" : sDispatch = "SpinButton"
Case UCase(sOOCommand) = "STATUSBARVISIBLE" : sDispatch = "StatusBarVisible"
Case UCase(sOOCommand) = "SWITCHCONTROLDESIGNMODE" : sDispatch = "SwitchControlDesignMode"
Case iVBACommand = acCmdTabOrder Or UCase(sOOCommand) = "TABDIALOG" : sDispatch = "TabDialog"
Case UCase(sOOCommand) = "USEWIZARDS" : sDispatch = "UseWizards"
Case UCase(sOOCommand) = "VERSIONDIALOG" : sDispatch = "VersionDialog"
Case UCase(sOOCommand) = "VIEWDATASOURCEBROWSER" : sDispatch = "ViewDataSourceBrowser"
Case iVBACommand = acCmdDatasheetView Or UCase(sOOCommand) = "VIEWFORMASGRID" : sDispatch = "ViewFormAsGrid"
Case iVBACommand = acCmdZoomSelection Or UCase(sOOCommand) = "ZOOM" : sDispatch = "Zoom"
Case Else
If iVBACommand >= 0 Then Goto Exit_Function
sDispatch = pvCommand
End Select

If pbReturnCommand Then RunCommand = cstUnoPrefix & sDispatch Else Call _DispatchCommand(cstUnoPrefix & sDispatch)

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
GoTo Exit_Function
End Function ' RunCommand V0.7.0
Access2BaseDev DoCmd RunSQL Basic CopyObject (Procedure) 30
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RunSQL(Optional ByVal pvSQL As Variant _
, Optional ByVal pvOption As Variant _
) As Boolean
' Return True if the execution of the SQL statement was successful
' SQL must contain an ACTION query

If _ErrorHandler() Then On Local Error Goto Error_Function

Utils._SetCalledSub("RunSQL")

RunSQL = False
If IsMissing(pvSQL) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
Const cstNull = -1
If IsMissing(pvOption) Then
pvOption = cstNull
Else
If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
End If

RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption)

Exit_Function:
Utils._ResetCalledSub("RunSQL")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "RunSQL", Erl)
GoTo Exit_Function
End Function ' RunSQL V1.1.0
Access2BaseDev DoCmd SelectObject Basic   48
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SelectObject( ByVal Optional pvObjectType As Variant _
, ByVal Optional pvObjectName As Variant _
, ByVal Optional pvInDatabaseWindow As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "SelectObject"
Utils._SetCalledSub(cstThisSub)

If IsMissing(pvObjectType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _
) Then Goto Exit_Function
If IsMissing(pvObjectName) Then
Select Case pvObjectType
Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
Case Else
End Select
pvObjectName = ""
Else
If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
End If
If Not IsMissing(pvInDatabaseWindow) Then
If Not Utils._CheckArgument(pvInDatabaseWindow, 3, vbBoolean, False) Then Goto Exit_Function
End If

Dim oWindow As Object
Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
If IsNull(oWindow.Frame) Then Goto Error_NotFound
With oWindow.Frame.ContainerWindow
If .isVisible() = False Then .setVisible(True)
.IsMinimized = False
.setFocus()
.setEnable(True) ' Added to try to bypass desynchro issue in Linux
.toFront() ' Added to force window change in Linux
End With

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' SelectObject V1.1.0
Access2BaseDev DoCmd SendObject Basic   101
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SendObject(ByVal Optional pvObjectType As Variant _
, ByVal Optional pvObjectName As Variant _
, ByVal Optional pvOutputFormat As Variant _
, ByVal Optional pvTo As Variant _
, ByVal Optional pvCc As Variant _
, ByVal Optional pvBcc As Variant _
, ByVal Optional pvSubject As Variant _
, ByVal Optional pvMessageText As Variant _
, ByVal Optional pvEditMessage As Variant _
, ByVal Optional pvTemplateFile As Variant _
) As Boolean
'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms
'To be prepared: acFormatCSV and acFormatODS for tables/queries ?
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("SendObject")
SendObject = False

If IsMissing(pvObjectType) Then pvObjectType = acSendNoObject
If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acSendNoObject, acSendForm)) Then Goto Exit_Function
If IsMissing(pvObjectName) Then pvObjectName = ""
If Not Utils._CheckArgument(pvObjectName, 2,vbString) Then Goto Exit_Function
If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
If pvOutputFormat <> "" Then
If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _
, "PDF", "ODT", "DOC", "HTML", "" _
)) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity
End If
If IsMissing(pvTo) Then pvTo = ""
If Not Utils._CheckArgument(pvTo, 4, vbString) Then Goto Exit_Function
If IsMissing(pvCc) Then pvCc = ""
If Not Utils._CheckArgument(pvCc, 5, vbString) Then Goto Exit_Function
If IsMissing(pvBcc) Then pvBcc = ""
If Not Utils._CheckArgument(pvBcc, 6, vbString) Then Goto Exit_Function
If IsMissing(pvSubject) Then pvSubject = ""
If Not Utils._CheckArgument(pvSubject, 7, vbString) Then Goto Exit_Function
If IsMissing(pvMessageText) Then pvMessageText = ""
If Not Utils._CheckArgument(pvMessageText, 8, vbString) Then Goto Exit_Function
If IsMissing(pvEditMessage) Then pvEditMessage = True
If Not Utils._CheckArgument(pvEditMessage, 9, vbBoolean) Then Goto Exit_Function
If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
If Not Utils._CheckArgument(pvTemplateFile,10, vbString, "") Then Goto Exit_Function

Dim vTo() As Variant, vCc() As Variant, vBcc() As Variant, oWindow As Object
Dim sDirectory As String, sOutputFile As String, sSuffix As String, sOutputFormat As String
Const cstSemiColon = ";"
If pvTo <> "" Then vTo() = Split(pvTo, cstSemiColon) Else vTo() = Array()
If pvCc <> "" Then vCc() = Split(pvCc, cstSemiColon) Else vCc() = Array()
If pvBcc <> "" Then vBcc() = Split(pvBcc, cstSemiColon) Else vBcc() = Array()
Select Case True
Case pvObjectType = acSendNoObject And pvObjectName = ""
SendObject = _SendWithoutAttachment(vTo, vCc, vBcc, pvSubject, pvMessageText)
Case Else
If pvObjectType = acSendNoObject And pvObjectName <> "" Then
If Not FileExists(pvObjectName) Then Goto Error_File
sOutputFile = pvObjectName
Else ' OutputFile has to be created
If pvObjectType <> acSendNoObject And pvObjectName = "" Then
oWindow = _SelectWindow()
If oWindow.WindowType <> acSendForm Then Goto Error_Action
pvObjectType = acSendForm
pvObjectName = oWindow._Name
End If
sDirectory = Utils._getTempDirectoryURL()
If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/"
If pvOutputFormat = "" Then
sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format
If sOutputFormat = "" Then Goto Exit_Function
Else
sOutputFormat = UCase(pvOutputFormat)
End If
Select Case sOutputFormat
Case UCase(acFormatPDF), "PDF" : sSuffix = "pdf"
Case UCase(acFormatDOC), "DOC" : sSuffix = "doc"
Case UCase(acFormatODT), "ODT" : sSuffix = "odt"
Case UCase(acFormatHTML), "HTML" : sSuffix = "html"
End Select
sOutputFile = sDirectory & pvObjectName & "." & sSuffix
If Not OutputTo(pvObjectType, pvObjectName, sOutputFormat, sOutputFile, False) Then Goto Exit_Function
End If
SendObject = _SendWithAttachment(vTo, vCc, vBcc, pvSubject, Array(sOutputFile), pvMessageText, pvEditMessage)
End Select

Exit_Function:
Utils._ResetCalledSub("SendObject")
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "SendObject", Erl)
GoTo Exit_Function
Error_Action:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
Goto Exit_Function
Error_File:
TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , pvObjectName)
Goto Exit_Function
End Function ' SendObject V0.8.5
Access2BaseDev DoCmd SetHiddenAttribute Basic   46
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _
, ByVal Optional pvObjectName As Variant _
, ByVal Optional pvHidden As Variant _
) As Boolean

If _ErrorHandler() Then On Local Error Goto Error_Function
SetHiddenAttribute = False
Const cstThisSub = "SetHiddenAttribute"
Utils._SetCalledSub(cstThisSub)

If IsMissing(pvObjectType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _
) Then Goto Exit_Function
If IsMissing(pvObjectName) Then
Select Case pvObjectType
Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
Case Else
End Select
pvObjectName = ""
Else
If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
End If
If IsMissing(pvHidden) Then
pvHidden = True
Else
If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function
End If

Dim oWindow As Object
Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
If IsNull(oWindow.Frame) Then Goto Error_NotFound
oWindow.Frame.ContainerWindow.setVisible(Not pvHidden)
SetHiddenAttribute = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' SetHiddenAttribute V1.1.0
Access2BaseDev DoCmd SetOrderBy Basic   54
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SetOrderBy( _
ByVal Optional pvOrder As Variant _
, ByVal Optional pvControlName As Variant _
) As Boolean
' Sort ann open table, query, form or subform (if pvControlName present)

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "SetOrderBy"
Utils._SetCalledSub(cstThisSub)
SetOrderBy = False

If IsMissing(pvOrder) Then pvOrder = ""
If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function
If IsMissing(pvControlName) Then pvControlName = ""
If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function

Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

sOrder = oDatabase._ReplaceSquareBrackets(pvOrder)

Set oWindow = _SelectWindow()
With oWindow
Select Case .WindowType
Case acForm
Set oTarget = _DatabaseForm(._Name, pvControlName)
Case acQuery, acTable
If pvControlName <> "" Then Goto Exit_Function
If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
' FormOperations returns <Null> in OpenOffice
Set oTarget = .Frame.Controller.FormOperations.Cursor
Case Else ' Ignore action
Goto Exit_Function
End Select
End With

With oTarget
.Order = sOrder
.reload()
End With
SetOrderBy = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' SetOrderBy V1.2.0
Access2BaseDev DoCmd ShowAllrecords Basic   31
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ShowAllrecords() As Boolean
' Removes any existing filter that exists on the current table, query or form

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "ShowAllRecords"
Utils._SetCalledSub(cstThisSub)
ShowAllRecords = False

Dim oWindow As Object, oDatabase As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

Set oWindow = _SelectWindow()
Select Case oWindow.WindowType
Case acForm, acQuery, acTable
RunCommand(acCmdRemoveFilterSort)
ShowAllrecords = True
Case Else ' Ignore action
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' ShowAllrecords V1.1.0
Access2BaseDev Event _Initialize Basic   155
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize(poEvent As Object)

Dim oObject As Object, i As Integer
Dim sShortcut As String, sAddShortcut As String, sArray() As String
Dim sImplementation As String, oSelection As Object
Dim iCurrentDoc As Integer, oDoc As Object
Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm"

If _ErrorHandler() Then On Local Error Goto Error_Function

Set oObject = poEvent.Source
_EventSource = oObject
sArray = Split(Utils._getUNOTypeName(poEvent), ".")
_EventType = UCase(sArray(UBound(sArray)))
If Utils._hasUNOProperty(poEvent, "EventName") Then _EventName = poEvent.EventName

Select Case _EventType
Case "DOCUMENTEVENT"
'SubComponent processing
Select Case UCase(_EventName)
Case UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened")
Set oSelection = poEvent.ViewController.getSelection()(0)
_SubComponentName = oSelection.Name
With com.sun.star.sdb.application.DatabaseObject
Select Case oSelection.Type
Case .TABLE : _SubComponentType = acTable
Case .QUERY : _SubComponentType = acQuery
Case .FORM : _SubComponentType = acForm
Case .REPORT : _SubComponentType = acReport
Case Else
End Select
End With
Case Else
End Select
Case "EVENTOBJECT"
Case "ACTIONEVENT"
Case "FOCUSEVENT"
_FocusChangeTemporary = poEvent.Temporary
Case "ITEMEVENT"
Case "INPUTEVENT", "KEYEVENT"
_KeyCode = poEvent.KeyCode
_KeyChar = poEvent.KeyChar
_KeyFunction = poEvent.KeyFunc
_KeyAlt = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD2)
_KeyCtrl = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD1)
_KeyShift = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.SHIFT)
Case "MOUSEEVENT"
_ButtonLeft = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.LEFT)
_ButtonRight = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.RIGHT)
_ButtonMiddle = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.MIDDLE)
_XPos = poEvent.X
_YPos = poEvent.Y
_ClickCount = poEvent.ClickCount
Case "ROWCHANGEEVENT"
_RowChangeAction = poEvent.Action
Case "TEXTEVENT"
Case "ADJUSTMENTEVENT", "DOCKINGEVENT", "ENDDOCKINGEVENT", "ENDPOPUPMODEEVENT", "ENHANCEDMOUSEEVENT" _
, "MENUEVENT", "PAINTEVENT", "SPINEVENT", "VCLCONTAINEREVENT", "WINDOWEVENT"
Goto Exit_Function
Case Else
Goto Exit_Function
End Select

' Evaluate ContextShortcut
sShortcut = ""
sImplementation = Utils._ImplementationName(oObject)

Select Case True
Case sImplementation = "stardiv.Toolkit.UnoDialogControl" ' Dialog
_ContextShortcut = "Dialogs!" & _EventSource.Model.Name
Goto Exit_Function
Case Left(sImplementation, 16) = "stardiv.Toolkit." ' Control in Dialog
_ContextShortcut = "Dialogs!" & _EventSource.Context.Model.Name _
& "!" & _EventSource.Model.Name
Goto Exit_Function
Case Else
End Select

iCurrentDoc = _A2B_.CurrentDocIndex(, False)
If iCurrentDoc < 0 Then Goto Exit_Function
Set oDoc = _A2B_.CurrentDocument(iCurrentDoc)

' To manage 2x triggers of "Before record action" form event
If _EventType = "ROWCHANGEEVENT" And sImplementation <> "com.sun.star.comp.forms.ODatabaseForm" Then _Recommendation = "IGNORE"

Do While sImplementation <> "SwXTextDocument"
sAddShortcut = ""
Select Case sImplementation
Case "com.sun.star.comp.forms.OFormsCollection" ' Do nothing
Case Else
If Utils._hasUNOProperty(oObject, "Model") Then
If oObject.Model.Name <> "MainForm" And oObject.Model.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Model.Name)
ElseIf Utils._hasUNOProperty(oObject, "Name") Then
If oObject.Name <> "MainForm" And oObject.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Name)
End If
If sAddShortcut <> "" Then
If sImplementation = cstDatabaseForm And oDoc.DbConnect = DBCONNECTBASE Then sAddShortcut = sAddShortcut & ".Form"
sShortcut = sAddShortcut & Iif(Len(sShortcut) > 0, "!" & sShortcut, "")
End If
End Select
Select Case True
Case Utils._hasUNOProperty(oObject, "Model")
Set oObject = oObject.Model.Parent
Case Utils._hasUNOProperty(oObject, "Parent")
Set oObject = oObject.Parent
Case Else
Goto Exit_Function
End Select
sImplementation = Utils._ImplementationName(oObject)
Loop
' Add Forms! prefix
' Select Case oDoc.DbConnect
' Case DBCONNECTBASE
If Utils._hasUNOProperty(oObject, "Args") Then ' Current object is a SwXTextDocument
For i = 0 To UBound(oObject.Args)
If oObject.Args(i).Name = "DocumentTitle" Then
sAddShortcut = Utils._Surround(oObject.Args(i).Value)
Exit For
End If
Next i
End If
sShortcut = "Forms!" & sAddShortcut & "!" & sShortcut
' Case DBCONNECTFORM
' sShortcut = "Forms!0!" & sShortcut
' End Select

sArray = Split(sShortcut, "!")
' If presence of "Forms!myform!myform.Form", eliminate 2nd element
' Eliminate anyway blanco subcomponents (e.g; Forms!!myForm)
If UBound(sArray) >= 2 Then
If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then sArray(1) = ""
sArray = Utils._TrimArray(sArray)
End If
' If first element ends with .Form, remove suffix
If UBound(sArray) >= 1 Then
If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then sArray(1) = left(sArray(1), Len(sArray(1)) - 5)
sShortcut = Join(sArray, "!")
End If
If Len(sShortcut) >= 2 Then
If Right(sShortcut, 1) = "!" Then
_ContextShortcut = Left(sShortcut, Len(sShortcut) - 1)
Else
_ContextShortcut = sShortcut
End If
End If

Exit_Function:
Exit Sub
Error_Function:
TraceError(TRACEWARNING, Err, "Event.Initialize", Erl)
GoTo Exit_Function
End Sub ' _Initialize V0.9.1
Access2BaseDev Event _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
19
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

Dim sSubComponentName As String, sSubComponentType As String
sSubComponentName = Iif(_SubComponentType > -1, "SubComponentName", "")
sSubComponentType = Iif(_SubComponentType > -1, "SubComponentType", "")
Dim sXPos As String, sYPos As String
sXPos = Iif(IsNull(_XPos), "", "XPos")
sYPos = Iif(IsNull(_YPos), "", "YPos")

_PropertiesList = Utils._TrimArray(Array( _
"ButtonLeft", "ButtonRight", "ButtonMiddle", "ClickCount" _
, "ContextShortcut", "EventName", "EventType", "FocusChangeTemporary", _
, "KeyAlt", "KeyChar", "KeyCode", "KeyCtrl", "KeyFunction", "KeyShift" _
, "ObjectType", "Recommendation", "RowChangeAction", "Source" _
, sSubComponentName, sSubComponentType, sXPos, sYPos _
))

End Function ' _PropertiesList
Access2BaseDev Event _PropertyGet Basic ButtonLeft (Procedure)
ButtonMiddle (Procedure)
ButtonRight (Procedure)
ClickCount (Procedure)
ContextShortcut (Procedure)
EventName (Procedure)
EventSource (Procedure)
EventType (Procedure)
FocusChangeTemporary (Procedure)
KeyAlt (Procedure)
KeyChar (Procedure)
KeyCode (Procedure)
KeyCtrl (Procedure)
KeyFunction (Procedure)
KeyShift (Procedure)
ObjectType (Procedure)
Properties (Procedure)
Recommendation (Procedure)
RowChangeAction (Procedure)
Source (Procedure)
SubComponentName (Procedure)
SubComponentType (Procedure)
XPos (Procedure)
YPos (Procedure)
getProperty (Procedure)
79
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Event.get" & psProperty)

_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("ButtonLeft")
_PropertyGet = _ButtonLeft
Case UCase("ButtonMiddle")
_PropertyGet = _ButtonMiddle
Case UCase("ButtonRight")
_PropertyGet = _ButtonRight
Case UCase("ClickCount")
_PropertyGet = _ClickCount
Case UCase("ContextShortcut")
_PropertyGet = _ContextShortcut
Case UCase("FocusChangeTemporary")
_PropertyGet = _FocusChangeTemporary
Case UCase("EventName")
_PropertyGet = _EventName
Case UCase("EventSource")
_PropertyGet = _EventSource
Case UCase("EventType")
_PropertyGet = _EventType
Case UCase("KeyAlt")
_PropertyGet = _KeyAlt
Case UCase("KeyChar")
_PropertyGet = _KeyChar
Case UCase("KeyCode")
_PropertyGet = _KeyCode
Case UCase("KeyCtrl")
_PropertyGet = _KeyCtrl
Case UCase("KeyFunction")
_PropertyGet = _KeyFunction
Case UCase("KeyShift")
_PropertyGet = _KeyShift
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Recommendation")
_PropertyGet = _Recommendation
Case UCase("RowChangeAction")
_PropertyGet = _RowChangeAction
Case UCase("Source")
If _ContextShortcut = "" Then
_PropertyGet = _EventSource
Else
_PropertyGet = getObject(_ContextShortcut)
End If
Case UCase("SubComponentName")
_PropertyGet = _SubComponentName
Case UCase("SubComponentType")
_PropertyGet = _SubComponentType
Case UCase("XPos")
If IsNull(_XPos) Then Goto Trace_Error
_PropertyGet = _XPos
Case UCase("YPos")
If IsNull(_YPos) Then Goto Trace_Error
_PropertyGet = _YPos
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Event.get" & psProperty)
Exit Function
Trace_Error:
' Errors are not displayed to avoid display infinite cycling
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, False, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet V1.1.0
Access2BaseDev Event ButtonLeft Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ButtonLeft() As Variant
ButtonLeft = _PropertyGet("ButtonLeft")
End Property ' ButtonLeft (get)
Access2BaseDev Event ButtonMiddle Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ButtonMiddle() As Variant
ButtonMiddle = _PropertyGet("ButtonMiddle")
End Property ' ButtonMiddle (get)
Access2BaseDev Event ButtonRight Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ButtonRight() As Variant
ButtonRight = _PropertyGet("ButtonRight")
End Property ' ButtonRight (get)
Access2BaseDev Event Class_Initialize Basic Class_Terminate (Procedure) 27
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJEVENT
_EventSource = Nothing
_EventType = ""
_EventName = ""
_SubComponentName = ""
_SubComponentType = -1
_ContextShortcut = ""
_ButtonLeft = False ' See com.sun.star.awt.MouseButton.XXX
_ButtonRight = False
_ButtonMiddle = False
_XPos = Null
_YPos = Null
_ClickCount = 0
_KeyCode = 0
_KeyChar = ""
_KeyFunction = com.sun.star.awt.KeyFunction.DONTKNOW
_KeyAlt = False
_KeyCtrl = False
_KeyShift = False
_FocusChangeTemporary = False
_RowChangeAction = 0
_Recommendation = ""
End Sub ' Constructor
Access2BaseDev Event Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Event ClickCount Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ClickCount() As Variant
ClickCount = _PropertyGet("ClickCount")
End Property ' ClickCount (get)
Access2BaseDev Event ContextShortcut Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ContextShortcut() As Variant
ContextShortcut = _PropertyGet("ContextShortcut")
End Property ' ContextShortcut (get)
Access2BaseDev Event Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Event EventName Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get EventName() As Variant
EventName = _PropertyGet("EventName")
End Property ' EventName (get)
Access2BaseDev Event EventSource Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get EventSource() As Variant
EventSource = _PropertyGet("EventSource")
End Property ' EventSource (get)
Access2BaseDev Event EventType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get EventType() As Variant
EventType = _PropertyGet("EventType")
End Property ' EventType (get)
Access2BaseDev Event FocusChangeTemporary Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get FocusChangeTemporary() As Variant
FocusChangeTemporary = _PropertyGet("FocusChangeTemporary")
End Property ' FocusChangeTemporary (get)
Access2BaseDev Event getProperty Basic   12
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("Form.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Form.getProperty")

End Function ' getProperty
Access2BaseDev Event hasProperty Basic   8
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
Access2BaseDev Event KeyAlt Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get KeyAlt() As Variant
KeyAlt = _PropertyGet("KeyAlt")
End Property ' KeyAlt (get)
Access2BaseDev Event KeyChar Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get KeyChar() As Variant
KeyChar = _PropertyGet("KeyChar")
End Property ' KeyChar (get)
Access2BaseDev Event KeyCode Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get KeyCode() As Variant
KeyCode = _PropertyGet("KeyCode")
End Property ' KeyCode (get)
Access2BaseDev Event KeyCtrl Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get KeyCtrl() As Variant
KeyCtrl = _PropertyGet("KeyCtrl")
End Property ' KeyCtrl (get)
Access2BaseDev Event KeyFunction Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get KeyFunction() As Variant
KeyFunction = _PropertyGet("KeyFunction")
End Property ' KeyFunction (get)
Access2BaseDev Event KeyShift Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get KeyShift() As Variant
KeyShift = _PropertyGet("KeyShift")
End Property ' KeyShift (get)
Access2BaseDev Event ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Event Properties Basic   20
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, "", vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev Event Recommendation Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Recommendation() As Variant
Recommendation = _PropertyGet("Recommendation")
End Property ' Recommendation (get)
Access2BaseDev Event RowChangeAction Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get RowChangeAction() As Variant
RowChangeAction = _PropertyGet("RowChangeAction")
End Property ' RowChangeAction (get)
Access2BaseDev Event Source Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Source() As Variant
' Return the object having fired the event: Form, Control or SubForm
' Else return the root Database object
Source = _PropertyGet("Source")
End Function ' Source (get)
Access2BaseDev Event SubComponentName Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SubComponentName() As String
SubComponentName = _PropertyGet("SubComponentName")
End Property ' SubComponentName (get)
Access2BaseDev Event SubComponentType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SubComponentType() As Long
SubComponentType = _PropertyGet("SubComponentType")
End Property ' SubComponentType (get)
Access2BaseDev Event XPos Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get XPos() As Variant
XPos = _PropertyGet("XPos")
End Property ' XPos (get)
Access2BaseDev Event YPos Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get YPos() As Variant
YPos = _PropertyGet("YPos")
End Property ' YPos (get)
Access2BaseDev Field _PropertiesList Basic hasProperty (Procedure)
Properties (Procedure)
22
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

Select Case _ParentType
Case OBJTABLEDEF
_PropertiesList =Array("DataType", "dbType", "DefaultValue" _
, "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _
, "TypeName" _
)
Case OBJQUERYDEF
_PropertiesList = Array("DataType", "dbType", "DefaultValue" _
, "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _
, "TypeName" _
)
Case OBJRECORDSET
_PropertiesList = Array("DataType", "DataUpdatable", "dbType", "DefaultValue" _
, "Description" , "FieldSize", "Name", "ObjectType" _
, "Size", "SourceTable", "TypeName", "Value" _
)
End Select

End Function ' _PropertiesList
Access2BaseDev Field _PropertyGet Basic DataType (Procedure)
DataUpdatable (Procedure)
DbType (Procedure)
DefaultValue (Procedure)
Description (Procedure)
FieldSize (Procedure)
Name (Procedure)
ObjectType (Procedure)
Size (Procedure)
SourceField (Procedure)
SourceTable (Procedure)
TypeName (Procedure)
Value (Procedure)
getProperty (Procedure)
Properties (Procedure)
228
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "Field.get" & psProperty
Utils._SetCalledSub(cstThisSub)

If Not hasProperty(psProperty) Then Goto Trace_Error

Dim bCond1 As Boolean, bCond2 As Boolean, vValue As Variant, oValue As Object, sValue As String
Dim oSize As Object, lSize As Long, bNullable As Boolean, bNull As Boolean
Const cstMaxBinlength = 2 * 65535

_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("DataType")
_PropertyGet = Column.Type
Case UCase("DbType")
With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .BIT : _PropertyGet = dbBoolean
Case .TINYINT : _PropertyGet = dbInteger
Case .SMALLINT : _PropertyGet = dbLong
Case .INTEGER : _PropertyGet = dbLong
Case .BIGINT : _PropertyGet = dbBigInt
Case .FLOAT : _PropertyGet = dbFloat
Case .REAL : _PropertyGet = dbSingle
Case .DOUBLE : _PropertyGet = dbDouble
Case .NUMERIC : _PropertyGet = dbNumeric
Case .DECIMAL : _PropertyGet = dbDecimal
Case .CHAR : _PropertyGet = dbChar
Case .VARCHAR : _PropertyGet = dbText
Case .LONGVARCHAR : _PropertyGet = dbMemo
Case .CLOB : _PropertyGet = dbMemo
Case .DATE : _PropertyGet = dbDate
Case .TIME : _PropertyGet = dbTime
Case .TIMESTAMP : _PropertyGet = dbTimeStamp
Case .BINARY : _PropertyGet = dbBinary
Case .VARBINARY : _PropertyGet = dbVarBinary
Case .LONGVARBINARY : _PropertyGet = dbLongBinary
Case .BLOB : _PropertyGet = dbLongBinary
Case .BOOLEAN : _PropertyGet = dbBoolean
Case Else : _PropertyGet = dbUndefined
End Select
End With
Case UCase("DataUpdatable")
If Utils._hasUNOProperty(Column, "IsWritable") Then
_PropertyGet = Column.IsWritable
ElseIf Utils._hasUNOProperty(Column, "IsReadOnly") Then
_PropertyGet = Not Column.IsReadOnly
ElseIf Utils._hasUNOProperty(Column, "IsDefinitelyWritable") Then
_PropertyGet = Column.IsDefinitelyWritable
Else
_PropertyGet = False
End If
If Utils._hasUNOProperty(Column, "IsAutoIncrement") Then
If Column.IsAutoIncrement Then _PropertyGet = False ' Forces False if auto-increment (MSAccess)
End If
Case UCase("DefaultValue")
' default value buffered to avoid multiple calls
If Not _DefaultValueSet Then
If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement
_DefaultValue = Column.DefaultValue
ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition
If IsEmpty(Column.ControlDefault) Then _DefaultValue = "" Else _DefaultValue = Column.ControlDefault
Else
_DefaultValue = ""
End If
_DefaultValueSet = True
End If
_PropertyGet = _DefaultValue
Case UCase("Description")
bCond1 = Utils._hasUNOProperty(Column, "Description")
bCond2 = Utils._hasUNOProperty(Column, "HelpText")
Select Case True
Case ( bCond1 And bCond2 )
If IsEmpty(Column.HelpText) Then _PropertyGet = Column.Description Else _PropertyGet = Column.HelpText
Case ( bCond1 And ( Not bCond2 ) )
_PropertyGet = Column.Description
Case ( ( Not bCond1 ) And bCond2 )
_PropertyGet = Column.HelpText
Case Else
_PropertyGet = ""
End Select
Case UCase("FieldSize")
With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .VARCHAR, .LONGVARCHAR, .CLOB
Set oSize = Column.getCharacterStream
Case .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB
Set oSize = Column.getBinaryStream
Case Else
Set oSize = Nothing
End Select
End With
If Not IsNull(oSize) Then
bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
If bNullable Then
If Column.wasNull() Then _PropertyGet = 0 Else _PropertyGet = CLng(oSize.getLength())
Else
_PropertyGet = CLng(oSize.getLength())
End If
oSize.closeInput()
Else
_PropertyGet = EMPTY
End If
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Size")
With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .LONGVARCHAR, .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB, .CLOB
_PropertyGet = 0 ' Always 0 (MSAccess)
Case Else
If Utils._hasUNOProperty(Column, "Precision") Then _PropertyGet = Column.Precision Else _PropertyGet = 0
End Select
End With
Case UCase("SourceField")
Select Case _ParentType
Case OBJTABLEDEF
_PropertyGet = _Name
Case OBJQUERYDEF ' RealName = not documented ?!?
If Utils._hasUNOProperty(Column, "RealName") Then _PropertyGet = Column.RealName Else _PropertyGet = _Name
End Select
Case UCase("SourceTable")
Select Case _ParentType
Case OBJTABLEDEF
_PropertyGet = _ParentName
Case OBJQUERYDEF, OBJRECORDSET
_PropertyGet = Column.TableName
End Select
Case UCase("TypeName")
_PropertyGet = Column.TypeName
Case UCase("Value")
bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
bNull = False
With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .BIT, .BOOLEAN : vValue = Column.getBoolean() ' vbBoolean
Case .TINYINT : vValue = Column.getShort() ' vbInteger
Case .SMALLINT, .INTEGER: vValue = Column.getInt() ' vbLong
Case .BIGINT : vValue = Column.getLong() ' vbBigint
Case .FLOAT : vValue = Column.getFloat() ' vbSingle
Case .REAL, .DOUBLE : vValue = Column.getDouble() ' vbDouble
Case .NUMERIC, .DECIMAL
If Utils._hasUNOProperty(Column, "Scale") Then
If Column.Scale > 0 Then
vValue = Column.getDouble()
Else ' Try Long otherwise Double (CDec not implemented anymore in LO ?!?)
On Local Error Resume Next ' Avoid overflow error
' CLng checks local decimal point, getString does not !
sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint())
vValue = CLng(sValue)
If Err <> 0 Then
vValue = CDbl(sValue)
Err.Clear
On Local Error Goto Error_Function
End If
End If
Else
vValue = CDbl(Column.getString())
End If
Case .CHAR : vValue = Column.getString()
Case .VARCHAR : vValue = Column.getString() ' vbString
Case .LONGVARCHAR, .CLOB
Set oValue = Column.getCharacterStream()
If bNullable Then bNull = Column.wasNull()
If Not bNull Then
lSize = CLng(oValue.getLength())
oValue.closeInput()
vValue = Column.getString() ' vbString
Else
oValue.closeInput()
End If
Case .DATE : Set oValue = Column.getDate() ' vbObject with members VarType Unsigned Short = 18
If bNullable Then bNull = Column.wasNull()
If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day))
Case .TIME : Set oValue = Column.getTime() ' vbObject with members VarType Unsigned Short = 18
If bNullable Then bNull = Column.wasNull()
If Not bNull Then vValue = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds)
Case .TIMESTAMP : Set oValue = Column.getTimeStamp()
If bNullable Then bNull = Column.wasNull()
If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) _
+ TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds)
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
Set oValue = Column.getBinaryStream()
If bNullable Then bNull = Column.wasNull()
If Not bNull Then
lSize = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize
If lSize > cstMaxBinlength Then Goto Trace_Length
vValue = Array()
oValue.readBytes(vValue, lSize)
End If
oValue.closeInput()
Case Else
vValue = Column.getString() 'GIVE STRING A TRY
If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
End Select
If bNullable Then
If Column.wasNull() Then vValue = Null 'getXXX must precede wasNull()
End If
End With
_PropertyGet = vValue
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Length:
TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk"))
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet V1.1.0
Access2BaseDev Field _PropertySet Basic DefaultValue (Procedure)
Description (Procedure)
Value (Procedure)
AppendChunk (Procedure)
setProperty (Procedure)
162
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
' Return True if property setting OK

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "Field.set" & psProperty
Utils._SetCalledSub(cstThisSub)
_PropertySet = True
Dim iArgNr As Integer, vTemp As Variant
Dim oParent As Object

Select Case UCase(_A2B_.CalledSub)
Case UCase("setProperty") : iArgNr = 3
Case UCase("Field.setProperty") : iArgNr = 2
Case UCase(cstThisSub) : iArgNr = 1
End Select

If Not hasProperty(psProperty) Then Goto Trace_Error

Select Case UCase(psProperty)
Case UCase("DefaultValue")
If _ParentType <> OBJTABLEDEF Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition
Column.ControlDefault = pvValue
_DefaultValue = pvValue
_DefaultValueSet = True
End If
Case UCase("Description")
If _ParentType <> OBJTABLEDEF Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
Column.HelpText = pvValue
Case UCase("Value")
If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
If Not Column.IsWritable Then Goto Trace_Error_Updatable
If Column.IsReadOnly Then Goto Trace_Error_Updatable
If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
With com.sun.star.sdbc.DataType
If IsNull(pvValue) Then
If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then Column.updateNull() Else Goto Trace_Null
Else
Select Case Column.Type
Case .BIT, .BOOLEAN
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
Column.updateBoolean(pvValue)
Case .TINYINT
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < -128 Or pvValue > +127 Then Goto Trace_Error_Value
Column.updateShort(CInt(pvValue))
Case .SMALLINT
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < -32768 Or pvValue > 32767 Then Goto trace_Error_Value
Column.updateInt(CLng(pvValue))
Case .INTEGER
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto trace_Error_Value
Column.updateInt(CLng(pvValue))
Case .BIGINT
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
Column.updateLong(pvValue) ' No proper type conversion for HYPER data type
Case .FLOAT
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then Column.updateFloat(CSng(pvValue)) Else Goto trace_Error_Value
Case .REAL, .DOUBLE
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value
Column.updateDouble(CDbl(pvValue))
Case .NUMERIC, .DECIMAL
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(Column, "Scale") Then
If Column.Scale > 0 Then
'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value
Column.updateDouble(CDbl(pvValue))
Else
Column.updateString(CStr(pvValue))
End If
Else
Column.updateString(CStr(pvValue))
End If
Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If Len(pvValue) > _Precision Then Goto Trace_Error_Length
Column.updateString(pvValue) ' vbString
Case .DATE
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
vTemp = New com.sun.star.util.Date
With vTemp
.Day = Day(pvValue)
.Month = Month(pvValue)
.Year = Year(pvValue)
End With
Column.updateDate(vTemp)
Case .TIME
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
vTemp = New com.sun.star.util.Time
With vTemp
.Hours = Hour(pvValue)
.Minutes = Minute(pvValue)
.Seconds = Second(pvValue)
'.HundredthSeconds = 0 ' replaced with Long nanoSeconds in LO 4.1 ??
End With
Column.updateTime(vTemp)
Case .TIMESTAMP
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
vTemp = New com.sun.star.util.DateTime
With vTemp
.Day = Day(pvValue)
.Month = Month(pvValue)
.Year = Year(pvValue)
.Hours = Hour(pvValue)
.Minutes = Minute(pvValue)
.Seconds = Second(pvValue)
'.HundredthSeconds = 0
End With
Column.updateTimestamp(vTemp)
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
If Not IsArray(pvValue) Then Goto Trace_Error_Value
If UBound(pvValue) < LBound(pvValue) Then Goto Trace_Error_Value
If Not Utils._CheckArgument(pvValue(LBound(pvValue)), iArgNr, vbInteger, , False) Then Goto Trace_Error_Value
Column.updateBytes(pvValue)
Case Else
Goto trace_Error
End Select
End If
End With
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Trace_Null:
TraceError(TRACEFATAL, ERRNOTNULLABLE, Utils._CalledSub(), 0, 1, _Name)
_PropertySet = False
Goto Exit_Function
Trace_Error_Update:
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
_PropertySet = False
Goto Exit_Function
Trace_Error_Updatable:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
_PropertySet = False
Goto Exit_Function
Trace_Error_Length:
TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "AppendChunk"))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev Field _ReadAll Basic ReadAllBytes (Procedure)
ReadAllText (Procedure)
76
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ReadAll(ByVal psFile As String, ByVal psMethod As String) As Boolean
' Write the whole content of a file into a stream object

If _ErrorHandler() Then On Local Error Goto Error_Function
_ReadAll = False

If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
If Not Column.IsWritable Then Goto Trace_Error_Updatable
If Column.IsReadOnly Then Goto Trace_Error_Updatable
If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update

Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object
Dim lFileLength As Long, sBuffer As String, sMemo As String, iFile As Integer
Const cstMaxLength = 64000
sFile = ConvertToURL(psFile)

oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
If Not oSimpleFileAccess.exists(sFile) Then Goto Trace_File

With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
If psMethod <> "ReadAllBytes" Then Goto Trace_Error
Set oStream = oSimpleFileAccess.openFileRead(sFile)
lFileLength = oStream.getLength()
If lFileLength = 0 Then Goto Trace_File
Column.updateBinaryStream(oStream, lFileLength)
oStream.closeInput()
Case .VARCHAR, .LONGVARCHAR, .CLOB
If psMethod <> "ReadAllText" Then Goto Trace_Error
sMemo = ""
lFileLength = 0
iFile = FreeFile()
Open sFile For Input Access Read Shared As iFile
Do While Not Eof(iFile)
Line Input #iFile, sBuffer
lFileLength = lFileLength + Len(sBuffer) + 1
If lFileLength > cstMaxLength Then Exit Do
sMemo = sMemo & sBuffer & vbNewLine
Loop
If lFileLength = 0 Or lFileLength > cstMaxLength Then
Close #iFile
Goto Trace_File
End If
sMemo = Left(sMemo, lFileLength - 1)
Column.updateString(sMemo)
'Column.updateCharacterStream(oStream, lFileLength) ' DOES NOT WORK ?!?
Case Else
Goto Trace_Error
End Select
End With

_ReadAll = True

Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod)
Goto Exit_Function
Trace_File:
TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile)
If Not IsNull(oStream) Then oStream.closeInput()
Goto Exit_Function
Trace_Error_Update:
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
If Not IsNull(oStream) Then oStream.closeInput()
Goto Exit_Function
Trace_Error_Updatable:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
If Not IsNull(oStream) Then oStream.closeInput()
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, _CalledSub, Erl)
GoTo Exit_Function
End Function ' ReadAll
Access2BaseDev Field _WriteAll Basic WriteAllBytes (Procedure)
WriteAllText (Procedure)
53
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _WriteAll(ByVal psFile As String, ByVal psMethod As String) As Boolean
' Write the whole content of a stream object to a file

If _ErrorHandler() Then On Local Error Goto Error_Function
_WriteAll = False

Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object
sFile = ConvertToURL(psFile)

oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
If psMethod <> "WriteAllBytes" Then Goto Trace_Error
Set oStream = Column.getBinaryStream()
Case .VARCHAR, .LONGVARCHAR, .CLOB
If psMethod <> "WriteAllText" Then Goto Trace_Error
Set oStream = Column.getCharacterStream()
Case Else
Goto Trace_Error
End Select
End With

If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then
If Column.wasNull() Then Goto Trace_Null
End If
If oStream.getLength() = 0 Then Goto Trace_Null
On Local Error Goto Trace_File
If oSimpleFileAccess.exists(sFile) Then oSimpleFileAccess.kill(sFile)
oSimpleFileAccess.writeFile(sFile, oStream)
On Local Error Goto Error_Function
oStream.closeInput()

_WriteAll = True

Exit_Function:
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod)
Goto Exit_Function
Trace_File:
TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile)
If Not IsNull(oStream) Then oStream.closeInput()
Goto Exit_Function
Trace_Null:
TraceError(TRACEFATAL, ERRFIELDNULL, _CalledSub, 0)
If Not IsNull(oStream) Then oStream.closeInput()
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, _CalledSub, Erl)
GoTo Exit_Function
End Function ' WriteAll
Access2BaseDev Field AppendChunk Basic   50
REM -----------------------------------------------------------------------------------------------------------------------
Public Function AppendChunk(ByRef Optional pvValue As Variant) As Boolean
' Store a chunk of string or binary characters into the current field, presumably a large object (CLOB or BLOB)

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Field.AppendChunk"
Utils._SetCalledSub(cstThisSub)
AppendChunk = False

If IsMissing(pvValue) Then Call _TraceArguments()

If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
If Not Column.IsWritable Then Goto Trace_Error_Updatable
If Column.IsReadOnly Then Goto Trace_Error_Updatable
If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update

Dim iChunkType As Integer

With com.sun.star.sdbc.DataType
Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES
' Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
' iChunkType = vbString
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB, .CHAR ' .CHAR added for Sqlite3
iChunkType = vbByte
Case Else
Goto Trace_Error
End Select
End With

AppendChunk = _ParentRecordset._AppendChunk(_Name, pvValue, iChunkType)

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error_Update:
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
_PropertySet = False
Goto Exit_Function
Trace_Error_Updatable:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
_PropertySet = False
Goto Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' AppendChunk V1.5.0
Access2BaseDev Field Class_Initialize Basic Class_Terminate (Procedure) 12
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJFIELD
_Name = ""
_ParentName = ""
_ParentType = ""
_DefaultValue = ""
_DefaultValueSet = False
Set Column = Nothing
End Sub ' Constructor
Access2BaseDev Field Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Field DataType Basic   3
Property Get DataType() As Long		'	AOO/LibO type
DataType = _PropertyGet("DataType")
End Property ' DataType (get)
Access2BaseDev Field DataUpdatable Basic   3
Property Get DataUpdatable() As Boolean
DataUpdatable = _PropertyGet("DataUpdatable")
End Property ' DataUpdatable (get)
Access2BaseDev Field DbType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get DbType() As Long ' MSAccess type
DbType = _PropertyGet("DbType")
End Property ' DbType (get)
Access2BaseDev Field DefaultValue Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get DefaultValue() As Variant
DefaultValue = _PropertyGet("DefaultValue")
End Property ' DefaultValue (get)

Property Let DefaultValue(ByVal pvDefaultValue As Variant)
Call _PropertySet("DefaultValue", pvDefaultValue)
End Property ' DefaultValue (set)
Access2BaseDev Field Description Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Description() As Variant
Description = _PropertyGet("Description")
End Property ' Description (get)

Property Let Description(ByVal pvDescription As Variant)
Call _PropertySet("Description", pvDescription)
End Property ' Description (set)
Access2BaseDev Field Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Field FieldSize Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get FieldSize() As Long
FieldSize = _PropertyGet("FieldSize")
End Property ' FieldSize (get)
Access2BaseDev Field GetChunk Basic   64
REM -----------------------------------------------------------------------------------------------------------------------
Public Function GetChunk(ByVal Optional pvOffset As Variant, ByVal Optional pvBytes As Variant) As Variant
' Get a chunk of string or binary characters from the current field, presumably a large object (CLOB or BLOB)

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Field.GetChunk"
Utils._SetCalledSub(cstThisSub)

Dim oValue As Object, bNullable As Boolean, bNull As Boolean, vValue() As Variant
Dim lLength As Long, lOffset As Long, lValue As Long

If IsMissing(pvOffset) Or IsMissing(pvBytes) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvOffset, 1, _AddNumeric()) Then Goto Exit_Function
If pvOffset < 0 Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvOffset))
Goto Exit_Function
End If
If Not Utils._CheckArgument(pvBytes, 2, _AddNumeric()) Then Goto Exit_Function
If pvBytes < 0 Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(2, pvBytes))
Goto Exit_Function
End If

bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
bNull = False
GetChunk = Null
vValue = Array()
With com.sun.star.sdbc.DataType
Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES
' Case .CHAR, .VARCHAR, .LONGVARCHAR
' Set oValue = Column.getCharacterStream()
' Case .CLOB
' Set oValue = Column.getClob.getCharacterStream()
Case .BINARY, .VARBINARY, .LONGVARBINARY
Set oValue = Column.getBinaryStream()
Case .BLOB
Set oValue = Column.getBlob.getBinaryStream()
Case Else
Goto Trace_Error
End Select
If bNullable Then bNull = Column.wasNull()
If Not bNull Then
lOffset = CLng(pvOffset)
If lOffset > 0 Then oValue.skipBytes(lOffset)
lValue = oValue.readBytes(vValue, pvBytes)
End If
oValue.closeInput()
End With
GetChunk = vValue

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub)
Goto Exit_Function
Trace_Argument:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex))
Set vForms = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' GetChunk V1.5.0
Access2BaseDev Field getProperty Basic   11
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Const cstThisSub = "Field.getProperty"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub(cstThisSub)

End Function ' getProperty
Access2BaseDev Field hasProperty Basic _PropertyGet (Procedure)
_PropertySet (Procedure)
11
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)

Const cstThisSub = "Field.hasProperty"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
Utils._ResetCalledSub(cstThisSub)
Exit Function

End Function ' hasProperty
Access2BaseDev Field Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Field ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Field Properties Basic   25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String, sName As String
Const cstThisSub = "Field.Properties"
Utils._SetCalledSub(cstThisSub)
vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
sName = _ParentType & "/" & _ParentName & "/" & _Name
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, sName, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, sName, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If
Set vProperty._ParentDatabase = _ParentDatabase

Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Properties
Access2BaseDev Field ReadAllBytes Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ReadAllBytes(ByVal Optional pvFile As Variant) As Boolean
' Read the whole content of a file into Long Binary Field object

Const cstThisSub = "Field.ReadAllBytes"
Utils._SetCalledSub(cstThisSub)
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
ReadAllBytes = _ReadAll(pvFile, "ReadAllBytes")

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' ReadAllBytes
Access2BaseDev Field ReadAllText Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ReadAllText(ByVal Optional pvFile As Variant) As Boolean
' Read the whole content of a file into a Long Char Field object

Const cstThisSub = "Field.ReadAllText"
Utils._SetCalledSub(cstThisSub)
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
ReadAllText = _ReadAll(pvFile, "ReadAllText")

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' ReadAllText
Access2BaseDev Field setProperty Basic   8
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Const cstThisSub = "Field.setProperty"
Utils._SetCalledSub(cstThisSub)
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub(cstThisSub)
End Function
Access2BaseDev Field Size Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Size() As Long
Size = _PropertyGet("Size")
End Property ' Size (get)
Access2BaseDev Field SourceField Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SourceField() As String
SourceField = _PropertyGet("SourceField")
End Property ' SourceField (get)
Access2BaseDev Field SourceTable Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get SourceTable() As String
SourceTable = _PropertyGet("SourceTable")
End Property ' SourceTable (get)
Access2BaseDev Field TypeName Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get TypeName() As String
TypeName = _PropertyGet("TypeName")
End Property ' TypeName (get)
Access2BaseDev Field Value Basic   7
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)
Access2BaseDev Field WriteAllBytes Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function WriteAllBytes(ByVal Optional pvFile As Variant) As Boolean
' Write the whole content of a Long Binary Field object to a file

Const cstThisSub = "Field.WriteAllBytes"
Utils._SetCalledSub(cstThisSub)
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
WriteAllBytes = _WriteAll(pvFile, "WriteAllBytes")

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' WriteAllBytes
Access2BaseDev Field WriteAllText Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function WriteAllText(ByVal Optional pvFile As Variant) As Boolean
' Write the whole content of a Long Char Field object to a file

Const cstThisSub = "Field.WriteAllText"
Utils._SetCalledSub(cstThisSub)
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
WriteAllText = _WriteAll(pvFile, "WriteAllText")

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' WriteAllText
Access2BaseDev Form _GetListener Basic _PropertySet (Procedure) 26
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetListener(ByVal psProperty As String) As String
' Return the X...Listener corresponding with the property in argument

Select Case UCase(psProperty)
Case UCase("OnApproveCursorMove")
_GetListener = "XRowSetApproveListener"
Case UCase("OnApproveParameter")
_GetListener = "XDatabaseParameterListener"
Case UCase("OnApproveReset"), UCase("OnResetted")
_GetListener = "XResetListener"
Case UCase("OnApproveRowChange")
_GetListener = "XRowSetApproveListener"
Case UCase("OnApproveSubmit")
_GetListener = "XSubmitListener"
Case UCase("OnConfirmDelete")
_GetListener = "XConfirmDeleteListener"
Case UCase("OnCursorMoved"), UCase("OnRowChanged")
_GetListener = "XRowSetListener"
Case UCase("OnErrorOccurred")
_GetListener = "XSQLErrorListener"
Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading")
_GetListener = "XLoadListener"
End Select

End Function ' _GetListener V1.7.0
Access2BaseDev Form _Initialize Basic   54
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize(psName As String)
' Set pointers to UNO objects

Dim oDoc As Object, oDatabase As Object
If _ErrorHandler() Then On Local Error Goto Trace_Error
_Name = psName
_Shortcut = "Forms!" & Utils._Surround(psName)
If IsLoaded Then
Set oDoc = _A2B_.CurrentDocument()
Select Case oDoc.DbConnect
Case DBCONNECTBASE
If Not IsNull(Component.CurrentController) Then ' A form opened then closed afterwards keeps a Component attribute
Set ContainerWindow = Component.CurrentController.Frame.ContainerWindow
Set FormsCollection = Component.getDrawPage.Forms
If FormsCollection.Count = 0 Then
Set DatabaseForm = Nothing
Else
'Only first member of the collection can be reached with A2B
'Compliant with MSAccess which has 1 datasource by form, while LO might have many
_MainForms = FormsCollection.ElementNames()
Set DatabaseForm = FormsCollection.getByIndex(0)
End If
End If
Case DBCONNECTFORM
Set ContainerWindow = oDoc.Document.CurrentController.Frame.ContainerWindow
Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
With oDatabase
Set DatabaseForm = .Form
If IsNull(.Connection) Then
Set .Connection = DatabaseForm.ActiveConnection
If Not IsNull(.Connection) Then
Set .MetaData = .Connection.MetaData
oDatabase._ReadOnly = .Connection.isReadOnly()
End If
End If
End With
End Select
If IsNull(DatabaseForm) Then _OrderBy = "" Else _OrderBy = DatabaseForm.Order
Else
Set Component = Nothing
Set ContainerWindow = Nothing
Set DatabaseForm = Nothing
End If

Exit_Sub:
Exit Sub
Trace_Error:
TraceError(TRACEABORT, Err, "Form.Initialize", Erl)
Goto Exit_Sub
Trace_Internal_Error:
TraceError(TRACEABORT, ERRFORMNOTIDENTIFIED, Utils._CalledSub(), 0, , _Name)
Goto Exit_Sub
End Sub ' _Initialize V1.1.0
Access2BaseDev Form _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
18
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

If IsLoaded Then
_PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "Bookmark" _
, "Caption", "CurrentRecord", "Filter", "FilterOn", "Height", "IsLoaded" _
, "Name", "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _
, "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _
, "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _
, "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OpenArgs" _
, "OrderBy", "OrderByOn", "RecordSource", "Visible", "Width" _
) ' Recordset removed
Else
_PropertiesList = Array("IsLoaded", "Name" _
)
End If

End Function ' _PropertiesList
Access2BaseDev Form _PropertyGet Basic AllowAdditions (Procedure)
AllowDeletions (Procedure)
AllowEdits (Procedure)
Bookmark (Procedure)
Caption (Procedure)
CurrentRecord (Procedure)
Filter (Procedure)
FilterOn (Procedure)
Height (Procedure)
Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
OnApproveCursorMove (Procedure)
OnApproveParameter (Procedure)
OnApproveReset (Procedure)
OnApproveRowChange (Procedure)
OnApproveSubmit (Procedure)
OnConfirmDelete (Procedure)
OnCursorMoved (Procedure)
OnErrorOccurred (Procedure)
OnLoaded (Procedure)
OnReloaded (Procedure)
OnReloading (Procedure)
OnResetted (Procedure)
OnRowChanged (Procedure)
OnUnloaded (Procedure)
OnUnloading (Procedure)
OpenArgs (Procedure)
OrderBy (Procedure)
OrderByOn (Procedure)
Properties (Procedure)
Recordset (Procedure)
RecordSource (Procedure)
Visible (Procedure)
Width (Procedure)
getProperty (Procedure)
116
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Form.get" & psProperty)

'Execute
Dim oDatabase As Object, vBookmark As Variant
Dim i As Integer, oObject As Object

_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("Name"), UCase("IsLoaded")
Case Else : If Not IsLoaded Then Goto Trace_Error_Form
End Select

Select Case UCase(psProperty)
Case UCase("AllowAdditions")
If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowInserts
Case UCase("AllowDeletions")
If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowDeletes
Case UCase("AllowEdits")
If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowUpdates
Case UCase("Bookmark")
If IsNull(DatabaseForm) Then
_PropertyGet = 0
Else
On Local Error Resume Next ' Disable error handler because bookmarking does not always react well in events ...
If DatabaseForm.IsBookmarkable Then vBookmark = DatabaseForm.getBookmark() Else vBookmark = Nothing
If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0
If IsNull(vBookmark) Then Goto Trace_Error
_PropertyGet = vBookmark
End If
Case UCase("Caption")
Set odatabase = Application._CurrentDb(_DocEntry, _DbEntry)
Select Case oDatabase._DbConnect
Case DBCONNECTFORM : _PropertyGet = oDatabase.Document.CurrentController.Frame.Title
Case DBCONNECTBASE : _PropertyGet = Component.CurrentController.Frame.Title
End Select
Case UCase("CurrentRecord")
If IsNull(DatabaseForm) Then _PropertyGet = 0 Else _PropertyGet = DatabaseForm.Row
Case UCase("Filter")
If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Filter
Case UCase("FilterOn")
If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.ApplyFilter
Case UCase("Height")
_PropertyGet = ContainerWindow.getPosSize().Height
Case UCase("IsLoaded") ' Only for indirect access from property object
_PropertyGet = IsLoaded
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _
, UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _
, UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _
, UCase("OnUnloaded"), UCase("OnUnloading")
If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name, True)
Case UCase("OpenArgs")
_PropertyGet = _OpenArgs
Case UCase("OrderBy")
_PropertyGet = _OrderBy
Case UCase("OrderByOn")
If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = ( DatabaseForm.Order <> "" )
Case UCase("Recordset")
If IsNull(DatabaseForm) Then Goto Trace_Error
If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ??
Set oObject = New Recordset
With DatabaseForm
oObject._CommandType = .CommandType
oObject._Command = .Command
oObject._ParentName = _Name
oObject._ParentType = _Type
Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
Set oObject._ParentDatabase = oDatabase
Set oObject._ParentDatabase.Connection = .ActiveConnection
oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY )
oObject._PassThrough = ( .EscapeProcessing = False )
oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY )
Call oObject._Initialize()
End With
With oDatabase
.RecordsetMax = .RecordsetMax + 1
oObject._Name = Format(.RecordsetMax, "0000000")
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
End With
If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty
Set _PropertyGet = oObject
Case UCase("RecordSource")
If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Command
Case UCase("Visible")
_PropertyGet = ContainerWindow.IsVisible()
Case UCase("Width")
_PropertyGet = ContainerWindow.getPosSize().Width
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Form.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Form:
TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Form._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Form _PropertySet Basic AllowAdditions (Procedure)
AllowDeletions (Procedure)
AllowEdits (Procedure)
Bookmark (Procedure)
Caption (Procedure)
CurrentRecord (Procedure)
Filter (Procedure)
FilterOn (Procedure)
Height (Procedure)
OnApproveCursorMove (Procedure)
OnApproveParameter (Procedure)
OnApproveReset (Procedure)
OnApproveRowChange (Procedure)
OnApproveSubmit (Procedure)
OnConfirmDelete (Procedure)
OnCursorMoved (Procedure)
OnErrorOccurred (Procedure)
OnLoaded (Procedure)
OnReloaded (Procedure)
OnReloading (Procedure)
OnResetted (Procedure)
OnRowChanged (Procedure)
OnUnloaded (Procedure)
OnUnloading (Procedure)
OrderBy (Procedure)
OrderByOn (Procedure)
RecordSource (Procedure)
Visible (Procedure)
Width (Procedure)
setProperty (Procedure)
124
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean

Utils._SetCalledSub("Form.set" & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function
_PropertySet = True

'Execute
Dim iArgNr As Integer, i As Integer
Dim oDatabase As Object

If _Isleft(_A2B_.CalledSub, "Form.") Then iArgNr = 1 Else iArgNr = 2
If Not IsLoaded Then Goto Trace_Error_Form

Select Case UCase(psProperty)
Case UCase("AllowAdditions")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.AllowInserts = pvValue
DatabaseForm.reload()
Case UCase("AllowDeletions")
If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.AllowDeletes = pvValue
DatabaseForm.reload()
Case UCase("AllowEdits")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.AllowUpdates = pvValue
DatabaseForm.reload()
Case UCase("Bookmark")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbObject), , False) Then Goto Trace_Error_Value
If IsNull(pvValue) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.MoveToBookmark(pvValue)
Case UCase("Caption")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
Select Case oDatabase._DbConnect
Case DBCONNECTFORM : oDatabase.Document.CurrentController.Frame.Title = pvValue
Case DBCONNECTBASE : Component.CurrentController.Frame.Title = pvValue
End Select
Case UCase("CurrentRecord")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 1 Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.absolute(pvValue)
Case UCase("Filter")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
Case UCase("FilterOn")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.ApplyFilter = pvValue
DatabaseForm.reload()
Case UCase("Height")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2
ContainerWindow.IsMaximized = False
ContainerWindow.IsMinimized = False
End If
ContainerWindow.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT)
Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _
, UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _
, UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _
, UCase("OnUnloaded"), UCase("OnUnloading")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
If Not Utils._RegisterEventScript(DatabaseForm _
, psProperty _
, _GetListener(psProperty) _
, pvValue, _Name, True _
) Then GoTo Trace_Error
Case UCase("OrderBy")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
_OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
Case UCase("OrderByOn")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = ""
DatabaseForm.reload()
Case UCase("RecordSource")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If IsNull(DatabaseForm) Then Goto Trace_Error
DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND
DatabaseForm.Filter = ""
DatabaseForm.reload()
Case UCase("Visible")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
ContainerWindow.setVisible(pvValue)
Case UCase("Width")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value
If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2
ContainerWindow.IsMaximized = False
ContainerWindow.IsMinimized = False
End If
ContainerWindow.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH)
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Form.set" & psProperty)
Exit Function
Trace_Error_Form:
TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name)
_PropertySet = False
Goto Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Form._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev Form AllowAdditions Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AllowAdditions() As Variant
AllowAdditions = _PropertyGet("AllowAdditions")
End Property ' AllowAdditions (get)

Property Let AllowAdditions(ByVal pvValue As Variant)
Call _PropertySet("AllowAdditions", pvValue)
End Property ' AllowAdditions (set)
Access2BaseDev Form AllowDeletions Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AllowDeletions() As Variant
AllowDeletions = _PropertyGet("AllowDeletions")
End Property ' AllowDeletions (get)

Property Let AllowDeletions(ByVal pvValue As Variant)
Call _PropertySet("AllowDeletions", pvValue)
End Property ' AllowDeletions (set)
Access2BaseDev Form AllowEdits Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AllowEdits() As Variant
AllowEdits = _PropertyGet("AllowEdits")
End Property ' AllowEdits (get)

Property Let AllowEdits(ByVal pvValue As Variant)
Call _PropertySet("AllowEdits", pvValue)
End Property ' AllowEdits (set)
Access2BaseDev Form Bookmark Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Bookmark() As Variant
Bookmark = _PropertyGet("Bookmark")
End Property ' Bookmark (get)

Property Let Bookmark(ByVal pvValue As Variant)
Call _PropertySet("Bookmark", pvValue)
End Property ' Bookmark (set)
Access2BaseDev Form Caption Basic   7
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)
Access2BaseDev Form Class_Initialize Basic Class_Terminate (Procedure) 18
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJFORM
_Shortcut = ""
_Name = ""
_DocEntry = -1
_DbEntry = -1
_MainForms = Array()
_IsLoaded = False
_OpenArgs = ""
_OrderBy = ""
Set Component = Nothing
Set ContainerWindow = Nothing
Set FormsCollection = Nothing
Set DatabaseForm = Nothing
End Sub ' Constructor
Access2BaseDev Form Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Form Controls Basic   114
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
' Return a Control object with name or index = pvIndex

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Form.Controls")

Dim ocControl As Variant, iControlCount As Integer
Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String
Dim j As Integer, iCount As Integer, sName As String, iAddCount As Integer
Dim oDatabaseForm As Object, iCtlCount As Integer

Set ocControl = Nothing
If Not IsLoaded Then Goto Trace_Error_NotOpen
'Count number of controls thru the forms collection
iControlCount = 0
iCount = FormsCollection.Count
For i = 0 To iCount - 1
If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i)
If Not IsNull(oDatabaseForm) Then iControlCount = iControlCount + oDatabaseForm.getCount()
Next i

If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object
Set oCounter = New Collect
oCounter._CollType = COLLCONTROLS
oCounter._ParentType = OBJFORM
oCounter._ParentName = _Name
oCounter._Count = iControlCount
Set Controls = oCounter
Goto Exit_Function
End If

If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function

' Start building the ocControl object
' Determine exact name

sName = ""
Select Case VarType(pvIndex)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index
iAddCount = 0
For i = 0 To iCount - 1
If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i)
If Not IsNull(oDatabaseForm) Then
iCtlCount = oDatabaseForm.getCount()
If pvIndex >= iAddCount And pvIndex <= iAddcount + iCtlCount - 1 Then
sName = oDatabaseForm.ElementNames(pvIndex - iAddCount)
Exit For
End If
iAddCount = iAddcount +iCtlCount
End If
Next i
Case vbString ' Check control name validity (non case sensitive)
sIndex = UCase(Utils._Trim(pvIndex))
bFound = False
For i = 0 To iCount - 1
If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i)
If Not IsNull(oDatabaseForm) Then
sControls() = oDatabaseForm.getElementNames()
For j = 0 To UBound(sControls)
If UCase(sControls(j)) = sIndex Then
sName = sControls(j)
bFound = True
Exit For
End If
Next j
If bFound Then Exit For
End If
Next i
If Not bFound Then Goto Trace_NotFound
End Select

'Initialize a new Control object
Set ocControl = New Control
With ocControl
._ParentType = CTLPARENTISFORM
._Name = sName
._Shortcut = _Shortcut & "!" & Utils._Surround(sName)
If IsNull(oDatabaseForm) Then ._MainForm = "" Else ._MainForm = oDatabaseForm.Name
Set .ControlModel = oDatabaseForm.getByName(sName)
._ImplementationName = .ControlModel.getImplementationName()
._FormComponent = Component
If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId
If ._ClassId > 0 And ._ClassId <> acHiddenControl Then
Set .ControlView = Component.CurrentController.getControl(.ControlModel)
End If

._Initialize()
._DocEntry = _DocEntry
._DbEntry = _DbEntry
End With
Set Controls = ocControl

Exit_Function:
Utils._ResetCalledSub("Form.Controls")
Exit Function
Trace_Error_NotOpen:
TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , _Name)
Set Controls = Nothing
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set Controls = Nothing
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex))
Set Controls = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Form.Controls", Erl)
Set Controls = Nothing
GoTo Exit_Function
End Function ' Controls
Access2BaseDev Form CurrentDb Basic   13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDb() As Object
' Returns Database object related to current form

Const cstThisSub = "Form.CurrentDb"
Utils._SetCalledSub(cstThisSub)

Set CurrentDb = Application._CurrentDb(_DocEntry, _DbEntry)

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' CurrentDb V1.1.0
Access2BaseDev Form CurrentRecord Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get CurrentRecord() As Variant
CurrentRecord = _PropertyGet("CurrentRecord")
End Property ' CurrentRecord (get)

Property Let CurrentRecord(ByVal pvValue As Variant)
Call _PropertySet("CurrentRecord", pvValue)
End Property ' CurrentRecord (set)
Access2BaseDev Form Dispose Basic mClose (Procedure) 8
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Dim ofForm As Object
If Not IsLoaded(True) Then
If Not IsNull(DatabaseForm) Then DatabaseForm.Dispose()
End If
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Form Filter Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Filter() As Variant
Filter = _PropertyGet("Filter")
End Property ' Filter (get)

Property Let Filter(ByVal pvValue As Variant)
Call _PropertySet("Filter", pvValue)
End Property ' Filter (set)
Access2BaseDev Form FilterOn Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get FilterOn() As Variant
FilterOn = _PropertyGet("FilterOn")
End Property ' FilterOn (get)

Property Let FilterOn(ByVal pvValue As Variant)
Call _PropertySet("FilterOn", pvValue)
End Property ' FilterOn (set)
Access2BaseDev Form getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("Form.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Form.getProperty")

End Function ' getProperty
Access2BaseDev Form hasProperty Basic   8
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
Access2BaseDev Form Height Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Height() As Variant
Height = _PropertyGet("Height")
End Property ' Height (get)

Property Let Height(ByVal pvValue As Variant)
Call _PropertySet("Height", pvValue)
End Property ' Height (set)
Access2BaseDev Form IsLoaded Basic Dispose (Procedure)
Controls (Procedure)
_Initialize (Procedure)
_PropertiesList (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertiesList (Procedure)
53
REM -----------------------------------------------------------------------------------------------------------------------
Function IsLoaded(ByVal Optional pbForce As Boolean) As Boolean
'Return True if form open
'pbForce = True forbids bypass on value of _IsLoaded

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Form.getIsLoaded")
If IsMissing(pbForce) Then pbForce = False
If ( Not pbForce ) And _IsLoaded Then ' For performance reasons, a form object, once detected as loaded, is presumed remaining loaded. Except if pbForce = True
IsLoaded = True
Goto Exit_Function
End If
IsLoaded = False

Dim oDoc As Object, oDatabase As Object, oEnum As Object, oDesk As Object, oComp As Object, bFound As Boolean
Dim i As Integer
Set oDoc = _A2B_.CurrentDocument()
Select Case oDoc.DbConnect
Case DBCONNECTBASE
Set oDesk = CreateUnoService("com.sun.star.frame.Desktop")
Set oEnum = oDesk.Components().createEnumeration
bFound = False
Do While oEnum.hasMoreElements And Not bFound ' Search in all open components if one corresponds with current form
oComp = oEnum.nextElement
If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then
If oComp.Identifier = "com.sun.star.sdb.FormDesign" Then
For i = 0 To UBound(oComp.Args())
If oComp.Args(i).Name = "DocumentTitle" Then
bFound = ( oComp.Args(i).Value = _Name )
If bFound Then
_IsLoaded = True
Set Component = oComp
Exit For
End If
End If
Next i
End If
End If
Loop
Case DBCONNECTFORM
Set Component = oDoc.Document ' Form
_IsLoaded = True ' Interactive form always loaded by design
End Select
Set oComp = Nothing
IsLoaded = _IsLoaded

Exit_Function:
Utils._ResetCalledSub("Form.getIsLoaded")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Form.getIsLoaded", Erl)
GoTo Exit_Function
End Function ' IsLoaded V1.1.0
Access2BaseDev Form mClose Basic   25
Public Function mClose() As Variant
' Close the form

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Form.Close")
mClose = False
Dim oDatabase As Object, oController As Object
Set oDatabase = Application._CurrentDb()
If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable

Set oController = oDatabase.Document.getFormDocuments.getByName(_Name)
oController.close()
Dispose()
mClose = True

Exit_Function:
Utils._ResetCalledSub("Form.Close")
Exit Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Form.Close", Erl)
GoTo Exit_Function
End Function
Access2BaseDev Form Move Basic   63
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Move( ByVal Optional pvLeft As Variant _
, ByVal Optional pvTop As Variant _
, ByVal Optional pvWidth As Variant _
, ByVal Optional pvHeight As Variant _
) As Variant
' Execute Move method
Utils._SetCalledSub("Form.Move")
If IsMissing(pvLeft) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function
Move = False
Dim iArgNr As Integer
Select Case UCase(_A2B_.CalledSub)
Case UCase("Move") : iArgNr = 1
Case UCase("Form.Move") : iArgNr = 0
End Select
If IsMissing(pvLeft) Then Call _TraceArguments()
If IsMissing(pvTop) Then pvTop = -1
If IsMissing(pvWidth) Then pvWidth = -1
If IsMissing(pvHeight) Then pvHeight = -1
If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function
If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function

Dim iArg As Integer, iWrong As Integer ' Check arguments values
iArg = 0
If pvHeight < -1 Then
iArg = 4 : iWrong = pvHeight
ElseIf pvWidth < -1 Then
iArg = 3 : iWrong = pvWidth
ElseIf pvTop < -1 Then
iArg = 2 : iWrong = pvTop
ElseIf pvLeft < -1 Then
iArg = 1 : iWrong = pvLeft
End If
If iArg > 0 Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong))
Goto Exit_Function
End If

Dim iPosSize As Integer
iPosSize = 0
If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X
If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y
If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH
If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT
If iPosSize > 0 Then
If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2
ContainerWindow.IsMaximized = False
ContainerWindow.IsMinimized = False
End If
ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize)
End If
Move = True

Exit_Function:
Utils._ResetCalledSub("Form.Move")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Form.Move", Erl)
GoTo Exit_Function
End Function ' Move
Access2BaseDev Form Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Form ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Form OnApproveCursorMove Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveCursorMove() As Variant
OnApproveCursorMove = _PropertyGet("OnApproveCursorMove")
End Property ' OnApproveCursorMove (get)

Property Let OnApproveCursorMove(ByVal pvValue As Variant)
Call _PropertySet("OnApproveCursorMove", pvValue)
End Property ' OnApproveCursorMove (set)
Access2BaseDev Form OnApproveParameter Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveParameter() As Variant
OnApproveParameter = _PropertyGet("OnApproveParameter")
End Property ' OnApproveParameter (get)

Property Let OnApproveParameter(ByVal pvValue As Variant)
Call _PropertySet("OnApproveParameter", pvValue)
End Property ' OnApproveParameter (set)
Access2BaseDev Form OnApproveReset Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveReset() As Variant
OnApproveReset = _PropertyGet("OnApproveReset")
End Property ' OnApproveReset (get)

Property Let OnApproveReset(ByVal pvValue As Variant)
Call _PropertySet("OnApproveReset", pvValue)
End Property ' OnApproveReset (set)
Access2BaseDev Form OnApproveRowChange Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveRowChange() As Variant
OnApproveRowChange = _PropertyGet("OnApproveRowChange")
End Property ' OnApproveRowChange (get)

Property Let OnApproveRowChange(ByVal pvValue As Variant)
Call _PropertySet("OnApproveRowChange", pvValue)
End Property ' OnApproveRowChange (set)
Access2BaseDev Form OnApproveSubmit Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveSubmit() As Variant
OnApproveSubmit = _PropertyGet("OnApproveSubmit")
End Property ' OnApproveSubmit (get)

Property Let OnApproveSubmit(ByVal pvValue As Variant)
Call _PropertySet("OnApproveSubmit", pvValue)
End Property ' OnApproveSubmit (set)
Access2BaseDev Form OnConfirmDelete Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnConfirmDelete() As Variant
OnConfirmDelete = _PropertyGet("OnConfirmDelete")
End Property ' OnConfirmDelete (get)

Property Let OnConfirmDelete(ByVal pvValue As Variant)
Call _PropertySet("OnConfirmDelete", pvValue)
End Property ' OnConfirmDelete (set)
Access2BaseDev Form OnCursorMoved Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnCursorMoved() As Variant
OnCursorMoved = _PropertyGet("OnCursorMoved")
End Property ' OnCursorMoved (get)

Property Let OnCursorMoved(ByVal pvValue As Variant)
Call _PropertySet("OnCursorMoved", pvValue)
End Property ' OnCursorMoved (set)
Access2BaseDev Form OnErrorOccurred Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnErrorOccurred() As Variant
OnErrorOccurred = _PropertyGet("OnErrorOccurred")
End Property ' OnErrorOccurred (get)

Property Let OnErrorOccurred(ByVal pvValue As Variant)
Call _PropertySet("OnErrorOccurred", pvValue)
End Property ' OnErrorOccurred (set)
Access2BaseDev Form OnLoaded Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnLoaded() As Variant
OnLoaded = _PropertyGet("OnLoaded")
End Property ' OnLoaded (get)

Property Let OnLoaded(ByVal pvValue As Variant)
Call _PropertySet("OnLoaded", pvValue)
End Property ' OnLoaded (set)
Access2BaseDev Form OnReloaded Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnReloaded() As Variant
OnReloaded = _PropertyGet("OnReloaded")
End Property ' OnReloaded (get)

Property Let OnReloaded(ByVal pvValue As Variant)
Call _PropertySet("OnReloaded", pvValue)
End Property ' OnReloaded (set)
Access2BaseDev Form OnReloading Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnReloading() As Variant
OnReloading = _PropertyGet("OnReloading")
End Property ' OnReloading (get)

Property Let OnReloading(ByVal pvValue As Variant)
Call _PropertySet("OnReloading", pvValue)
End Property ' OnReloading (set)
Access2BaseDev Form OnResetted Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnResetted() As Variant
OnResetted = _PropertyGet("OnResetted")
End Property ' OnResetted (get)

Property Let OnResetted(ByVal pvValue As Variant)
Call _PropertySet("OnResetted", pvValue)
End Property ' OnResetted (set)
Access2BaseDev Form OnRowChanged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnRowChanged() As Variant
OnRowChanged = _PropertyGet("OnRowChanged")
End Property ' OnRowChanged (get)

Property Let OnRowChanged(ByVal pvValue As Variant)
Call _PropertySet("OnRowChanged", pvValue)
End Property ' OnRowChanged (set)
Access2BaseDev Form OnUnloaded Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnloaded() As Variant
OnUnloaded = _PropertyGet("OnUnloaded")
End Property ' OnUnloaded (get)

Property Let OnUnloaded(ByVal pvValue As Variant)
Call _PropertySet("OnUnloaded", pvValue)
End Property ' OnUnloaded (set)
Access2BaseDev Form OnUnloading Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnloading() As Variant
OnUnloading = _PropertyGet("OnUnloading")
End Property ' OnUnloading (get)

Property Let OnUnloading(ByVal pvValue As Variant)
Call _PropertySet("OnUnloading", pvValue)
End Property ' OnUnloading (set)
Access2BaseDev Form OpenArgs Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OpenArgs() As Variant
OpenArgs = _PropertyGet("OpenArgs")
End Property ' OpenArgs (get)
Access2BaseDev Form OptionGroup Basic _OptionGroup (Procedure) 24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant
' Return either an error or an object of type OPTIONGROUP based on its name

Const cstThisSub = "Form.OptionGroup"
Dim ogGroup As Object
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvGroupName) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function

Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, Component, FormsCollection)
If Not IsNull(ogGroup) Then
ogGroup._DocEntry = _DocEntry
ogGroup._DbEntry = _DbEntry
End If
Set OptionGroup = ogGroup

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, Form.OptionGroup, Erl)
GoTo Exit_Function
End Function ' OptionGroup V1.1.0
Access2BaseDev Form OrderBy Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OrderBy() As Variant
OrderBy = _PropertyGet("OrderBy")
End Property ' OrderBy (get) V1.2.0

Property Let OrderBy(ByVal pvValue As Variant)
Call _PropertySet("OrderBy", pvValue)
End Property ' OrderBy (set)
Access2BaseDev Form OrderByOn Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OrderByOn() As Variant
OrderByOn = _PropertyGet("OrderByOn")
End Property ' OrderByOn (get) V1.2.0

Property Let OrderByOn(ByVal pvValue As Variant)
Call _PropertySet("OrderByOn", pvValue)
End Property ' OrderByOn (set)
Access2BaseDev Form pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev Form Properties Basic   20
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, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev Form Recordset Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Recordset() As Object
Recordset = _PropertyGet("Recordset")
End Property ' Recordset (get) V0.9.5
Access2BaseDev Form RecordSource Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get RecordSource() As Variant
RecordSource = _PropertyGet("RecordSource")
End Property ' RecordSource (get)

Property Let RecordSource(ByVal pvValue As Variant)
Call _PropertySet("RecordSource", pvValue)
End Property ' RecordSource (set)
Access2BaseDev Form Refresh Basic   22
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Refresh() As Boolean
' Refresh data with its most recent value in the database in a form or subform
Utils._SetCalledSub("Form.Refresh")
If _ErrorHandler() Then On Local Error Goto Error_Function
Refresh = False

Dim oSet As Object
Set oSet = DatabaseForm.createResultSet()
If Not IsNull(oSet) Then
oSet.refreshRow()
Refresh = True
End If

Exit_Function:
Set oSet = Nothing
Utils._ResetCalledSub("Form.Refresh")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl)
GoTo Exit_Function
End Function ' Refresh
Access2BaseDev Form Requery Basic   17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Requery() As Boolean
' Refresh data displayed in a form, subform, combobox or listbox
Utils._SetCalledSub("Form.Requery")
If _ErrorHandler() Then On Local Error Goto Error_Function
Requery = False

DatabaseForm.reload()
Requery = True

Exit_Function:
Utils._ResetCalledSub("Form.Requery")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Form.Requery", Erl)
GoTo Exit_Function
End Function ' Requery
Access2BaseDev Form setFocus Basic   24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFocus() As Boolean
' Execute setFocus method
Const cstThisSub = "Form.setFocus"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function
setFocus = False

With ContainerWindow
If .isVisible() = False Then .setVisible(True)
.IsMinimized = False
.setFocus()
.setEnable(True) ' Added to try to bypass desynchro issue in Linux
.toFront() ' Added to force window change in Linux
End With
setFocus = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Goto Exit_Function
End Function ' setFocus V1.1.0
Access2BaseDev Form setProperty Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Utils._SetCalledSub("Form.setProperty")
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub("Form.setProperty")
End Function
Access2BaseDev Form Visible Basic   7
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)
Access2BaseDev Form Width Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Width() As Variant
Width = _PropertyGet("Width")
End Property ' Width (get)

Property Let Width(ByVal pvValue As Variant)
Call _PropertySet("Width", pvValue)
End Property ' Width (set)
Access2BaseDev L10N _GetLabel Basic CommandBars (Procedure)
TempVars (Procedure)
TraceConsole (Procedure)
TraceError (Procedure)
_DumpToFile (Procedure)
_ErrorMessage (Procedure)
mClose (Procedure)
CopyObject (Procedure)
GetHiddenAttribute (Procedure)
OpenForm (Procedure)
OutputTo (Procedure)
Quit (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
_OpenObject (Procedure)
_PromptFormat (Procedure)
_CalledSub (Procedure)
_ResetCalledSub (Procedure)
_SetCalledSub (Procedure)
OpenRecordset (Procedure)
OutputTo (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
TableDefs (Procedure)
Delete (Procedure)
_GetLabelArray (Procedure)
Fields (Procedure)
Fields (Procedure)
486
Public Function _GetLabel(ByVal psShortlabel As String, Optional ByVal psLocale As String) As String
' Return the localized label corresponding with ShortLabel

If IsMissing(psLocale) Then psLocale = UCase(Left(_A2B_.Locale, 2)) Else psLocale = UCase(psLocale)
On Local Error Goto Error_Function
If Not Utils._InList(psLocale, Array( _
"EN", "FR", "ES", "DE" _
)) Then psLocale = "DEFAULT" ' If list incomplete a recursive call will be provided anyway

Dim sLocal As String
sLocal = psShortLabel
Select Case psLocale
Case "EN", "DEFAULT"
Select Case UCase(psShortlabel)
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No active connection to a database found"
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Arguments are missing or are not initialized"
Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument nr. %0 [Value = '%1'] is invalid"
Case "ERR" & ERRMAINFORM : sLocal = "Document '%0' does not contain any form"
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Form '%0' not identified in database Forms set"
Case "ERR" & ERRFORMNOTFOUND : sLocal = "Form '%0' not found"
Case "ERR" & ERRFORMNOTOPEN : sLocal = "Form '%0' is currently not open"
Case "ERR" & ERRDFUNCTION : sLocal = "DFunction execution failed, SQL=%0"
Case "ERR" & ERROPENFORM : sLocal = "Form '%0' could not be opened"
Case "ERR" & ERRPROPERTY : sLocal = "Property '%0' not applicable in this context"
Case "ERR" & ERRPROPERTYVALUE : sLocal = "Value '%0' is invalid for property '%1'"
Case "ERR" & ERRINDEXVALUE : sLocal = "Out of array range or incorrect array size for property '%0'"
Case "ERR" & ERRCOLLECTION : sLocal = "Out of array range"
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument nr.%0 should be an array"
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Control '%0' not found in parent (form, grid or dialog) '%1'"
Case "ERR" & ERRNOACTIVEFORM : sLocal = "No active form or control found"
Case "ERR" & ERRDATABASEFORM : sLocal = "Form '%0' has no underlying dataset"
Case "ERR" & ERRFOCUSINGRID : sLocal = "Control '%0' not found in gridcontrol '%1'"
Case "ERR" & ERRNOGRIDINFORM : sLocal = "No gridcontrol found in form '%0'"
Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() must be preceded by a successful FindRecord(...) call"
Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'"
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' not found"
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' could not be opened"
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' could not be closed"
Case "ERR" & ERRACTION : sLocal = "Action not applicable in this context"
Case "ERR" & ERRSENDMAIL : sLocal = "Mail service could not be activated"
Case "ERR" & ERRFORMYETOPEN : sLocal = "Form %0 is already open"
Case "ERR" & ERRMETHOD : sLocal = "Method '%0' not applicable in this context"
Case "ERR" & ERRPROPERTYINIT : sLocal = "Property '%0' applicable but not initialized"
Case "ERR" & ERRFILENOTCREATED : sLocal = "File '%0' could not be created"
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' not found in the currently loaded libraries"
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unknown"
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog already started"
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' not active"
Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset delivered no data. Action on current record rejected"
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset has been closed. Recordset action rejected"
Case "ERR" & ERRRECORDSETRANGE : sLocal = "Current record out of range"
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejected in a forward-only or not bookmarkable recordset"
Case "ERR" & ERRFIELDNULL : sLocal = "Field is null or empty. Action rejected"
Case "ERR" & ERRFILEACCESS : sLocal = "File access error on file '%0'"
Case "ERR" & ERROVERFLOW : sLocal = "Field length (%0) exceeds maximum length. Use the '%1' method instead"
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Query '%0' is not an action query"
Case "ERR" & ERRNOTUPDATABLE : sLocal = "Database, recordset or field is read only"
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Recordset update sequence error"
Case "ERR" & ERRNOTNULLABLE : sLocal = "Field '%0' must not contain a NULL value"
Case "ERR" & ERRROWDELETED : sLocal = "Current row has been deleted by another process or user"
Case "ERR" & ERRRECORDSETCLONE : sLocal = "Cloning a cloned Recordset is forbidden"
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Pre-existing query '%0' has been deleted"
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Pre-existing table '%0' has been deleted"
Case "ERR" & ERRTABLECREATION : sLocal = "Table '%0' could not be created"
Case "ERR" & ERRFIELDCREATION : sLocal = "Field '%0' could not be created"
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Subform '%0' not found in parent form '%1'"
Case "ERR" & ERRWINDOW : sLocal = "Current window is not a document"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Field '%0' could not be converted due to incompatibility of field types between the respective database systems"
Case "ERR" & ERRPRECISION : sLocal = "Field '%0' could not be loaded in record #%1 due to capacity shortage"
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries"
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Object"
Case "TABLE" : sLocal = "Table"
Case "QUERY" : slocal = "Query"
Case "FORM" : sLocal = "Form"
Case "REPORT" : sLocal = "Report"
Case "RECORDSET" : sLocal = "Recordset"
Case "FIELD" : sLocal = "Field"
Case "TEMPVAR" : sLocal = "Temporary variable"
Case "COMMANDBAR" : sLocal = "Command bar"
Case "COMMANDBARCONTROL" : sLocal = "Command bar control"
'----------------------------------------------------------------------------------------------------------------------
Case "ERR#" : sLocal = "Error #"
Case "ERROCCUR" : sLocal = "occurred"
Case "ERRLINE" : sLocal = "at line"
Case "ERRIN" : sLocal = "in"
Case "CALLTO" : sLocal = "a call to function"
Case "SAVECONSOLE" : sLocal = "Save console"
Case "SAVECONSOLEENTRIES" : sLocal = "The console entries have been saved successfully."
Case "QUITSHORT" : sLocal = "Quit"
Case "QUIT" : sLocal = "Do you really want to quit the application ? Changed data will be saved."
Case "ENTERING" : sLocal = "Entering"
Case "EXITING" : sLocal = "Exiting"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGTRACE_HELP" : sLocal = "Manage the console buffer and its entries"
Case "DLGTRACE_TITLE" : sLocal = "Console"
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Clear the list and resize the circular buffer"
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Set max number of entries"
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text can be selected, copied, ..."
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log file is empty ---"
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog"
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancel"
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Clear the list"
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Clear the list"
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Register only logging requests above given level"
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Set minimal trace level"
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validate"
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK"
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Choose a file and dump the actual list content in it"
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Dump to file"
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Actual size of list"
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Actual number of entries:"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGFORMAT_HELP" : sLocal = "Export the form"
Case "DLGFORMAT_TITLE" : sLocal = "OutputTo"
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format in which the form should be exported"
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Select the output format"
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validate your choice"
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK"
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog"
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancel"
'----------------------------------------------------------------------------------------------------------------------
Case Else : sLocal = ""
End Select
Case "FR"
Select Case UCase(psShortlabel)
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Pas de connexion active trouvée à une banque de données"
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Des arguments sont manquants ou non initialisés"
Case "ERR" & ERRWRONGARGUMENT : sLocal = "L'argument n° %0 [Valeur = '%1'] n'est pas valable"
Case "ERR" & ERRMAINFORM : sLocal = "Le document '%0' ne contient aucun formulaire"
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Le formulaire '%0' n'a pas pu être identifié parmi l'ensemble des formulaires de la Database"
Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formulaire '%0' non trouvé"
Case "ERR" & ERRFORMNOTOPEN : sLocal = "Le formulaire '%0' n'est actuellement pas ouvert"
Case "ERR" & ERRDFUNCTION : sLocal = "L'exécution de la ""fonction database"" a échoué, SQL=%0"
Case "ERR" & ERROPENFORM : sLocal = "Le formulaire '%0' n'a pas pu être ouvert"
Case "ERR" & ERRPROPERTY : sLocal = "La propriété '%0' n'est pas applicable dans ce contexte"
Case "ERR" & ERRPROPERTYVALUE : sLocal = "La valeur '%0' est invalide pour la propriété '%1'"
Case "ERR" & ERRINDEXVALUE : sLocal = "Indice invalide ou dimension erronée du tableau pour la propriété '%0'"
Case "ERR" & ERRCOLLECTION : sLocal = "Indice de tableau invalide"
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "L'argument n°%0 doit être un tableau"
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Contrôle '%0' non trouvé dans le parent (formulaire, contrôle de table ou dialogue) '%1'"
Case "ERR" & ERRNOACTIVEFORM : sLocal = "Pas de formulaire ou de contrôle actif"
Case "ERR" & ERRDATABASEFORM : sLocal = "Le formulaire '%0' n'a pas de données sous-jacentes"
Case "ERR" & ERRFOCUSINGRID : sLocal = "Contrôle '%0' non trouvé dans le contrôle de table '%1'"
Case "ERR" & ERRNOGRIDINFORM : sLocal = "Aucun contrôle de table trouvé dans le formulaire '%0'"
Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() doit être précédé par un appel réussi à FindRecord(...)"
Case "ERR" & ERRSQLSTATEMENT : sLocal = "Erreur SQL, instruction SQL = '%0'"
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' non trouvé(e)"
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1': ouverture en échec"
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1': fermeture en échec"
Case "ERR" & ERRACTION : sLocal = "Action non applicable dans ce contexte"
Case "ERR" & ERRSENDMAIL : sLocal = "Le service de messagerie n'a pas pu être activé"
Case "ERR" & ERRFORMYETOPEN : sLocal = "Le formulaire %0 est déjà ouvert"
Case "ERR" & ERRMETHOD : sLocal = "La méthode '%0' n'est pas applicable dans ce contexte"
Case "ERR" & ERRPROPERTYINIT : sLocal = "Propriété '%0' applicable mais non initialisée"
Case "ERR" & ERRFILENOTCREATED : sLocal = "Erreur de création du fichier '%0'"
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialogue '%0' introuvable dans les librairies chargées actuellement"
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Boîte de dialogue inconnue"
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialogue déjà initialisé précédemment"
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialogue '%0' non initialisé"
Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset n'a pas fourni de données. Toute action sur les enregistrements est rejetée"
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset a été clôturé. Action sur l'enregistrement courant est rejetée"
Case "ERR" & ERRRECORDSETRANGE : sLocal = "L'enregistrement courant est hors cadre"
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejetée car recordset lisible seulement vers l'avant ou n'acceptant pas de signets"
Case "ERR" & ERRFIELDNULL : sLocal = "Champ nul ou vide. Action rejetée"
Case "ERR" & ERRFILEACCESS : sLocal = "Erreur d'accès au fichier '%0'"
Case "ERR" & ERROVERFLOW : sLocal = "La longueur du champ (%0) dépasse la taille maximale autorisée. Utiliser de préférence la méthode '%1'"
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La requête '%0' n'est pas une requête d'action"
Case "ERR" & ERRNOTUPDATABLE : sLocal = "La banque de données, le recordset ou le champ sont en lecture seulement"
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Erreur de séquence lors de la mise à jour d'un Recordset"
Case "ERR" & ERRNOTNULLABLE : sLocal = "Le champ '%0' ne peut pas recevoir une valeur NULLe"
Case "ERR" & ERRROWDELETED : sLocal = "L'enregistrement courant a été effacé par un autre processus ou un autre utilisateur"
Case "ERR" & ERRRECORDSETCLONE : sLocal = "Le clonage d'un Recordset cloné est interdit"
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "La requête existante '%0' a été supprimée"
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "La table existante '%0' a été supprimée"
Case "ERR" & ERRTABLECREATION : sLocal = "La table '%0' n'a pas pu être créée"
Case "ERR" & ERRFIELDCREATION : sLocal = "Le champ '%0' n'a pas pu être créé"
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Sous-formulaire '%0' non trouvé dans le formulaire parent '%1'"
Case "ERR" & ERRWINDOW : sLocal = "La fenêtre courante n'est pas un document"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Le champ '%0' n'a pas pu être converti à cause d'une incompatibilité entre les types de champs supportés par les systèmes de bases de données respectifs"
Case "ERR" & ERRPRECISION : sLocal = "Le champ '%0' n'a pas pu être chargé dans l'enregistrement #%1 par manque de capacité"
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Le module '%0' est introuvable dans les librairies chargées actuellement"
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "La procédure '%0' est introuvable dans le module '%1'"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Objet"
Case "TABLE" : sLocal = "Table"
Case "QUERY" : slocal = "Requête"
Case "FORM" : sLocal = "Formulaire"
Case "REPORT" : sLocal = "Rapport"
Case "RECORDSET" : sLocal = "Recordset"
Case "FIELD" : sLocal = "Champ"
Case "TEMPVAR" : sLocal = "Variable temporaire"
Case "COMMANDBAR" : sLocal = "Barre de commande"
Case "COMMANDBARCONTROL" : sLocal = "Elément de barre de commande"
'----------------------------------------------------------------------------------------------------------------------
Case "ERR#" : sLocal = "L'erreur #"
Case "ERROCCUR" : sLocal = "s'est produite"
Case "ERRLINE" : sLocal = "à la ligne"
Case "ERRIN" : sLocal = "dans"
Case "CALLTO" : sLocal = "un appel à la fonction"
Case "SAVECONSOLE" : sLocal = "Sauver console"
Case "SAVECONSOLEENTRIES" : sLocal = "Les entrées de la console ont été sauvées avec succès."
Case "QUITSHORT" : sLocal = "Quitter"
Case "QUIT" : sLocal = "Voulez-vous réellement quitter l'application ? Les données modifiées seront sauvées."
Case "ENTERING" : sLocal = "Entrée dans"
Case "EXITING" : sLocal = "Sortie de"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGTRACE_HELP" : sLocal = "Gestion du tampon de la console et toutes ses entrées"
Case "DLGTRACE_TITLE" : sLocal = "Console"
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Effacer la liste et redimensionner le tampon circulaire"
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Définir le nombre maximum d'entrées"
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Le texte peut être sélectionné, copié, ..."
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Le fichier journal est vide ---"
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue"
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Annuler"
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Effacer la liste"
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Effacer la liste"
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "N'enregistrer que les demandes de journalisation à partir du niveau indiqué"
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Définir le niveau minimal d'enregistrement"
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Valider"
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK"
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Sélectionner un fichier et y vider le contenu actuel des traces enregistrées"
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Vider dans fichier"
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Taille actuelle de la liste"
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Nombre actuel d'entrées:"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGFORMAT_HELP" : sLocal = "Exporter le formulaire"
Case "DLGFORMAT_TITLE" : sLocal = "OutputTo"
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format dans lequel le formulaire sera exporté"
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Selectionner le format de sortie"
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Valider votre choix"
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK"
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue"
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Annuler"
'----------------------------------------------------------------------------------------------------------------------
Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT")
End Select
'********************************************************
'Translated by Iñigo Zuluaga
'********************************************************
Case "ES" '(España)
Select Case UCase(psShortlabel)
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No se ha encontrado una conexión activa a una base de datos"
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Faltan argumentos o no están inicializados"
Case "ERR" & ERRWRONGARGUMENT : sLocal = "El argumento nr. %0 [Value = '%1'] no es válido"
Case "ERR" & ERRMAINFORM : sLocal = "El documento '%0' no contiene ningún formulario"
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "No se ha identificado el formulario '%0' en el conjunto de formularios de la base de datos"
Case "ERR" & ERRFORMNOTFOUND : sLocal = "No se ha encontrado el formulario '%0'"
Case "ERR" & ERRFORMNOTOPEN : sLocal = "El formulario '%0' no está abierto"
Case "ERR" & ERRDFUNCTION : sLocal = "La ejecución de DFunction falló, SQL=%0"
Case "ERR" & ERROPENFORM : sLocal = "El formulario '%0' no se puede abrir"
Case "ERR" & ERRPROPERTY : sLocal = "La propiedad '%0' no es aplicable en este contexto"
Case "ERR" & ERRPROPERTYVALUE : sLocal = "El valor '%0' es inválido para la propiedad '%1'"
Case "ERR" & ERRINDEXVALUE : sLocal = "Fuera del rango de la matriz o tamaño incorrecto de la matriz para la propiedad '%0'"
Case "ERR" & ERRCOLLECTION : sLocal = "Fuera del rango de la matriz"
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "El argumento nr.%0 debería ser una matriz"
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "El control '%0' not found in parent (formulario, control de tabla or diálogo) '%1'"
Case "ERR" & ERRNOACTIVEFORM : sLocal = "No se ha encontrado un formulario o control activo"
Case "ERR" & ERRDATABASEFORM : sLocal = "El formulario '%0' no tiene datos subyacentes"
Case "ERR" & ERRFOCUSINGRID : sLocal = "No se ha encontrado el control '%0' en el control de tabla '%1'"
Case "ERR" & ERRNOGRIDINFORM : sLocal = "No se ha encontrado un control de tabla en el formulario '%0'"
Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() tiene que ser precedido por una llamada exitosa de FindRecord(...)"
Case "ERR" & ERRSQLSTATEMENT : sLocal = "Error SQL, instrución SQL = '%0'"
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' no encontrado"
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' no se puede abrir"
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' no se puede abrir"
Case "ERR" & ERRACTION : sLocal = "Acción no aplicable en este contexto"
Case "ERR" & ERRSENDMAIL : sLocal = "No se puede activar el servicio de correo"
Case "ERR" & ERRFORMYETOPEN : sLocal = "El formulario %0 ya está abierto"
Case "ERR" & ERRMETHOD : sLocal = "El método '%0' no es aplicable en este contexto"
Case "ERR" & ERRPROPERTYINIT : sLocal = "Propiedad '%0' aplicable pero no inicializada"
Case "ERR" & ERRFILENOTCREATED : sLocal = "No se ha podido crear el archivo '%0'"
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "No se ha encontrado el diálogo '%0' en las bibliotecas cargadas actualmente"
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Diálogo desconocido"
Case "ERR" & ERRDIALOGSTARTED : sLocal = "El diálogo ya está iniciado"
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "El diálogo '%0' no está activo"
Case "ERR" & ERRRECORDSETNODATA : sLocal = "El Recordset no suministra datos. La acción en el registro actual rechazada"
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "El recorset se ha cerrado. Acción con el Recordset rechazada"
Case "ERR" & ERRRECORDSETRANGE : sLocal = "Registro actual fuera de rango"
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Acción rechazada en un recorset legible sólo hacia adelante o que no admita marcadores"
Case "ERR" & ERRFIELDNULL : sLocal = "El campo es nulo o vacío. Acción rechazada"
Case "ERR" & ERRFILEACCESS : sLocal = "Error durante el acceso al archivo '%0'"
Case "ERR" & ERROVERFLOW : sLocal = "La longitud del campo (%0) excede la longitud máxima. Reemplazar por el método '%1'"
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La consulta '%0' no es una consulta de acción"
Case "ERR" & ERRNOTUPDATABLE : sLocal = "La base de datos, el Recordset o el Campo es de sólo lectura"
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Error durante la secuencia de actualización del Recordset"
Case "ERR" & ERRNOTNULLABLE : sLocal = "El campo '%0' no puede contener un valor NULL"
Case "ERR" & ERRROWDELETED : sLocal = "La fila actual ha sido borrada por otro proceso o usuario"
Case "ERR" & ERRRECORDSETCLONE : sLocal = "No se puede clonar un Recordset clonado"
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Se ha borrado la consulta pre-existente '%0'"
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Se ha borrado la tabla pre-existente '%0'"
Case "ERR" & ERRTABLECREATION : sLocal = "No se ha podido crear la Tabla '%0'"
Case "ERR" & ERRFIELDCREATION : sLocal = "No se ha podido crear el campo '%0'"
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "No se ha encontrado el Subformulario '%0' en el subformulario padre '%1'"
Case "ERR" & ERRWINDOW : sLocal = "La ventana actual no es un documento"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "El campo '%0' no se ha convertido debido a una incompatibilidad de los tipos de campo soportados entre las dos bases de datos"
Case "ERR" & ERRPRECISION : sLocal = "El campo '%0' no se ha cargado en el registro #%1 por falta de capacidad"
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries"
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Objeto"
Case "TABLE" : sLocal = "Tabla"
Case "QUERY" : slocal = "Consulta"
Case "FORM" : sLocal = "Formulario"
Case "REPORT" : sLocal = "Informe"
Case "RECORDSET" : sLocal = "Recordset"
Case "FIELD" : sLocal = "Campo"
Case "TEMPVAR" : sLocal = "Variable temporal"
Case "COMMANDBAR" : sLocal = "Barra de comandos"
Case "COMMANDBARCONTROL" : sLocal = "Control de barra de comandos"
'----------------------------------------------------------------------------------------------------------------------
Case "ERR#" : sLocal = "Error #"
Case "ERROCCUR" : sLocal = "ocurrido"
Case "ERRLINE" : sLocal = "en línea"
Case "ERRIN" : sLocal = "en"
Case "CALLTO" : sLocal = "una llamada a la función"
Case "SAVECONSOLE" : sLocal = "Guardar consola"
Case "SAVECONSOLEENTRIES" : sLocal = "Las entradas de la consola han sido guardadas correctamente."
Case "QUITSHORT" : sLocal = "Cerrar"
Case "QUIT" : sLocal = "Quieres realmente cerrar la aplicación? los datos cambiados se guardarán."
Case "ENTERING" : sLocal = "Entrando"
Case "EXITING" : sLocal = "Saliendo"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGTRACE_HELP" : sLocal = "Gestión del buffer de la consola y sus entradas"
Case "DLGTRACE_TITLE" : sLocal = "Consola"
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Limpiar la lista y redimensionar el buffer circular"
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Definir el número máximo de entradas"
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "El texto puede ser seleccionado, copiado, ..."
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- El archivo Histórico está vacío ---"
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo"
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancelar"
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Limpiar la lista"
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Limpiar la lista"
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "No registrar más que las peticiones de registro a partir de un nivel indicado"
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Definir el nivel mínimo de registro"
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validar"
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "Aceptar"
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Elegir un archivo y guardar en él el contenido de la lista actual"
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Guardar en a archivo"
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Tamaño actual de la lista"
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Numero actual de entradas:"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGFORMAT_HELP" : sLocal = "Exportar el formulario"
Case "DLGFORMAT_TITLE" : sLocal = "Exportar como"
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Formato en el que será ser exportado el formulario"
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Seleccionar el formato de salida"
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validar su elección"
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "Aceptar"
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo"
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancelar"
'----------------------------------------------------------------------------------------------------------------------
Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT")
End Select
'********************************************************
'Translated by Gisbert Friege
'********************************************************
Case "DE"
Select Case UCase(psShortlabel)
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Keine aktive Verbindung zu einer Datenbank gefunden"
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Argumente fehlen oder sind nicht initialisiert"
Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument Nr. %0 [Wert = '%1'] ist ungültig"
Case "ERR" & ERRMAINFORM : sLocal = "Dokument '%0' enthält kein Formular"
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Formular '%0' nicht bei den Datenbank-Formularen erkannt"
Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formular '%0' nicht gefunden"
Case "ERR" & ERRFORMNOTOPEN : sLocal = "Formular '%0' ist zur Zeit nicht offen"
Case "ERR" & ERRDFUNCTION : sLocal = "DFunction Ausführung misslungen, SQL=%0"
Case "ERR" & ERROPENFORM : sLocal = "Formular '%0' konnte nicht geöffnet werden"
Case "ERR" & ERRPROPERTY : sLocal = "Eigenschaft '%0' in diesem Kontext nicht anwendbar"
Case "ERR" & ERRPROPERTYVALUE : sLocal = "Wert '%0' ist ungültig für die Eigenschaft '%1'"
Case "ERR" & ERRINDEXVALUE : sLocal = "Außerhalb des Array-Bereichs oder falsche Array-Größe für Eigenschaft '%0'"
Case "ERR" & ERRCOLLECTION : sLocal = "Außerhalb des Array-Bereichs"
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument Nr.%0 sollte ein Array sein"
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Steuerelement '%0' nicht gefunden in parent (Formular, Tabelle oder Dialog) '%1'"
Case "ERR" & ERRNOACTIVEFORM : sLocal = "Kein aktives Formular oder Steuerelement gefunden"
Case "ERR" & ERRDATABASEFORM : sLocal = "Formular '%0' basiert nicht auf einem Datensatz"
Case "ERR" & ERRFOCUSINGRID : sLocal = "Steuerelement '%0' im Tabellen-Steuerelement '%1' nicht gefunden"
Case "ERR" & ERRNOGRIDINFORM : sLocal = "Kein Tabellen-Steuerelement im Formular '%0' gefunden"
Case "ERR" & ERRFINDRECORD : sLocal = "Bei FindNext() muss ein erfolgreicher FindRecord(...)-Aufruf vorhergehen"
Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'"
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' nicht gefunden"
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' konnte nicht geöffnet werden"
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' konnte nicht geschlossen werden"
Case "ERR" & ERRACTION : sLocal = "Aktion in diesem Kontext nicht anwendbar"
Case "ERR" & ERRSENDMAIL : sLocal = "Email-Dienst konnte nicht aktiviert werden"
Case "ERR" & ERRFORMYETOPEN : sLocal = "Formular %0 ist schon offen"
Case "ERR" & ERRMETHOD : sLocal = "Methode '%0' in diesem Kontext nicht anwendbar"
Case "ERR" & ERRPROPERTYINIT : sLocal = "Eigenschaft '%0' anwendbar aber nicht initialisiert"
Case "ERR" & ERRFILENOTCREATED : sLocal = "Datei '%0' konnte nicht erzeugt werden"
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' nicht in den aktuell geladenen Bibliotheken gefunden"
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unbekannt"
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog schon gestartet"
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' nicht aktiv"
Case "ERR" & ERRRECORDSETNODATA : sLocal = "Datensatz ergab keine Daten. Aktion auf aktuellem Datensatz verweigert"
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Datensatz wurde geschlossen. Datensatz-Aktion verweigert"
Case "ERR" & ERRRECORDSETRANGE : sLocal = "Aktueller Datensatz außerhalb des Bereichs"
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Aktion verweigert auf einem nur vorwärts lesbaren oder keine Textmarken unterstützenden Datensatz"
Case "ERR" & ERRFIELDNULL : sLocal = "Feld ist null oder leer. Aktion verweigert"
Case "ERR" & ERRFILEACCESS : sLocal = "Dateizugriffs-Fehler bei Datei '%0'"
Case "ERR" & ERROVERFLOW : sLocal = "Feldlänge (%0) überschreitet die maximale Länge. Verwende stattdessen die Methode '%1'"
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Abfrage '%0' ist keine Aktionsabfrage"
Case "ERR" & ERRNOTUPDATABLE : sLocal = "Datenbank, Datensatz oder Feld kann nur gelesen werden"
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Datensatz-Update Folgefehler"
Case "ERR" & ERRNOTNULLABLE : sLocal = "Feld '%0' darf keinen NULL-Wert haben"
Case "ERR" & ERRROWDELETED : sLocal = "Aktuelle Zeile wurde durch einen anderen Prozess oder Benutzer gelösch"
Case "ERR" & ERRRECORDSETCLONE : sLocal = "Ein geklonter Datensatz kann nicht geklont werden"
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Bereits vorhandene Abfrage '%0' wurde gelöscht"
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Bereits vorhandene Tabelle '%0' wurde gelöscht"
Case "ERR" & ERRTABLECREATION : sLocal = "Tabelle '%0' konnte nicht erzeugt werden"
Case "ERR" & ERRFIELDCREATION : sLocal = "Feld '%0' konnte nicht erzeugt werden"
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Unterformular '%0' nicht im Eltern-Formular '%1‘ gefunden"
Case "ERR" & ERRWINDOW : sLocal = "Aktuelles Fenster ist kein Dokument"
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Feld '%0' konnte wegen inkompatibler Feldtypen der Datenbanksysteme nicht konvertiert werden"
Case "ERR" & ERRPRECISION : sLocal = "Feld '%0' konnte wegen fehlender Speicherkapazität nicht in den Datensatz #%1 geladen werden"
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Modul '%0' nicht gefunden in den aktuell geladen Bibliotheken"
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Prozedur '%0' im Modul '%1' nicht gefunden"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT" : sLocal = "Objekt"
Case "TABLE" : sLocal = "Tabelle"
Case "QUERY" : slocal = "Abfrage"
Case "FORM" : sLocal = "Formular"
Case "REPORT" : sLocal = "Report"
Case "RECORDSET" : sLocal = "Datensatz"
Case "FIELD" : sLocal = "Feld"
Case "TEMPVAR" : sLocal = "Temporäre Variable"
Case "COMMANDBAR" : sLocal = "Befehlsleiste"
Case "COMMANDBARCONTROL" : sLocal = "Befehlsleisten-Steuerelement"
'----------------------------------------------------------------------------------------------------------------------
Case "ERR#" : sLocal = "Error #"
Case "ERROCCUR" : sLocal = "aufgetreten"
Case "ERRLINE" : sLocal = "in Zeile"
Case "ERRIN" : sLocal = "in"
Case "CALLTO" : sLocal = "ein Funktionsaufruf"
Case "SAVECONSOLE" : sLocal = "Konsoleneingaben sichern"
Case "SAVECONSOLEENTRIES" : sLocal = "Die Konsoleneingaben wurden erfolgreich gesichert."
Case "QUITSHORT" : sLocal = "Beenden"
Case "QUIT" : sLocal = "Wollen Sie wirklich die Anwendung beenden? Geänderte Daten werden gesichert."
Case "ENTERING" : sLocal = "Beginne mit"
Case "EXITING" : sLocal = "Verlasse"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGTRACE_HELP" : sLocal = "Verwalte den Konsolenpuffer und seine Eingaben"
Case "DLGTRACE_TITLE" : sLocal = "Konsole"
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Leere die Liste und ändere die Größe des Umlaufpuffers"
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Setze maximale Anzahl von Eingaben"
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text kann ausgewählt, kopiert, ... werden"
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log Datei ist leer ---"
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen"
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Abbrechen"
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Leere die Liste"
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Leere die Liste"
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Registriere nur Logging-Anfragen oberhalb des gegebenen Levels"
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Setze minimalen Fehlerbehandlungs-Level"
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Übernehmen"
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK"
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Wähle eine Datei und speichere darin den aktuellen Listeninhalt"
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Ausgabe in Datei"
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Aktuelle Länge der Liste"
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Aktuelle Anzahl von Einträgen:"
'----------------------------------------------------------------------------------------------------------------------
Case "DLGFORMAT_HELP" : sLocal = "Exportiere das Formular"
Case "DLGFORMAT_TITLE" : sLocal = "Export"
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format, in dem das Formular exportiert werden soll"
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Wähle das Ausgabe-Format"
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Auswahl übernehmen"
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK"
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen"
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Abbrechen"
'----------------------------------------------------------------------------------------------------------------------
Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT")
End Select
REM *******************************************************************************************************************************************
REM *** ***
REM *** ANY OTHER LANGUAGE TO BE INSERTED HERE ***
REM *** ***
REM *******************************************************************************************************************************************
Case Else
sLocal = _Getlabel(psShortLabel, "DEFAULT")
End Select

Exit_Function:
_Getlabel = sLocal
Exit Function
Error_Function:
sLocal = psShortLabel
GoTo Exit_Function
End Function ' GetLabel V0.8.9
Access2BaseDev L10N _GetLabelArray Basic   27
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetLabelArray(ByVal pvShortlabel As Variant, Optional ByVal psLocale As String) As Variant
' Return the localized label corresponding with the ShortLabel array of strings

If IsMissing(psLocale) Then psLocale = UCase(Left(_GetLocale(), 2)) Else psLocale = UCase(psLocale)
On Local Error Goto Error_Function

Dim vLocal() As Variant, i As integer
vLocal = Array()

If Not IsArray(pvShortLabel) Then
vLocal = _GetLabel(pvShortLabel, psLocale)
Goto Exit_Function
End If

ReDim vLocal(LBound(pvShortLabel) To UBound(pvShortlabel))
For i = LBound(pvShortLabel) To UBound(pvShortlabel)
vLocal(i) = _GetLabel(pvShortLabel(i), psLocale)
Next i

Exit_Function:
_GetlabelArray = vLocal()
Exit Function
Error_Function:
vLocal = Array()
GoTo Exit_Function
End Function ' GetLabelArray V0.8.9
Access2BaseDev L10N _GetLocale Basic _GetLabelArray (Procedure)
Class_Initialize (Procedure)
9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetLocale() as String
'Return OO localization
'Derived from Tools library

Dim oLocale as Object
oLocale = _GetRegistryKeyContent("org.openoffice.Setup/L10N")
_GetLocale = oLocale.getByName("ooLocale")
End Function ' GetLocale V0.8.9
Access2BaseDev Methods _OptionGroup Basic OptionGroup (Procedure)
OptionGroup (Procedure)
100
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _OptionGroup(ByVal pvGroupName As Variant _
, ByVal psParentType As String _
, poComponent As Object _
, poParent As Object _
) As Variant
' Return either an error or an object of type OPTIONGROUP based on its name

If IsMissing(pvGroupName) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function
Set _OptionGroup = Nothing

If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function

Dim ogGroup As Variant, i As Integer, j As Integer, bFound As Boolean
Dim vOptionButtons() As Variant, sGroupName As String
Dim lXY() As Long, iIndex() As Integer ' Two indexes X-Y coordinates
Dim oView As Object, oDatabaseForm As Object, vControls As Variant

Const cstPixels = 10 ' Tolerance on coordinates when drawed approximately

bFound = False
Select Case psParentType
Case CTLPARENTISFORM
'poParent is a forms collection, find the appropriate database form
For i = 0 To poParent.Count - 1
Set oDatabaseForm = poParent.getByIndex(i)
If Not IsNull(oDatabaseForm) Then
For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ?
oDatabaseForm.getGroup(j, vOptionButtons, sGroupName)
If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
bFound = True
Exit For
End If
Next j
If bFound Then Exit For
End If
If bFound Then Exit For
Next i
Case CTLPARENTISSUBFORM
'poParent is already a database form
Set oDatabaseForm = poParent
For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ?
oDatabaseForm.getGroup(j, vOptionButtons, sGroupName)
If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
bFound = True
Exit For
End If
Next j
End Select

If bFound Then

ogGroup = New Optiongroup
ogGroup._Name = sGroupName
ogGroup._ButtonsGroup = vOptionButtons
ogGroup._Count = UBound(vOptionButtons) + 1
ogGroup._ParentType = psParentType
ogGroup._MainForm = oDatabaseForm.Name
Set ogGroup._ParentComponent = poComponent

ReDim lXY(1, ogGroup._Count - 1)
ReDim iIndex(ogGroup._Count - 1)
For i = 0 To ogGroup._Count - 1 ' Find the position of each radiobutton
Set oView = poComponent.CurrentController.getControl(ogGroup._ButtonsGroup(i))
lXY(0, i) = oView.PosSize.X
lXY(1, i) = oView.PosSize.Y
Next i
For i = 0 To ogGroup._Count - 1 ' Sort them on XY coordinates
If i = 0 Then
iIndex(0) = 0
Else
iIndex(i) = i
For j = i - 1 To 0 Step -1
If lXY(1, i) - lXY(1, j) < - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) <= cstPixels And lXY(0, i) - lXY(0, j) < - cstPixels ) Then
iIndex(i) = iIndex(j)
iIndex(j) = iIndex(j) + 1
End If
Next j
End If
Next i
ogGroup._ButtonsIndex = iIndex()

Set _OptionGroup = ogGroup

Else

Set _OptionGroup = Nothing
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName))

End If

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEABORT, Err,"_OptionGroup", Erl)
GoTo Exit_Function
End Function ' _OptionGroup V1.1.0
Access2BaseDev Methods AddItem Basic Add (Procedure)
Remove (Procedure)
21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function AddItem(Optional pvBox As Variant, ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean
' Add an item in a Listbox

Utils._SetCalledSub("AddItem")
If _ErrorHandler() Then On Local Error Goto Error_Function

If IsMissing(pvBox) Or IsMissing(pvItem) Then Call _TraceArguments()
If IsMissing(pvIndex) Then pvIndex = -1
If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function

AddItem = pvBox.AddItem(pvItem, pvIndex)

Exit_Function:
Utils._ResetCalledSub("AddItem")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "AddItem", Erl)
AddItem = False
GoTo Exit_Function
End Function ' AddItem V0.9.0
Access2BaseDev Methods hasProperty Basic GoToControl (Procedure) 21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(Optional pvObject As Variant, ByVal Optional pvProperty As Variant) As Boolean
' Return True if pvObject has a valid property called pvProperty (case-insensitive comparison !)

Dim vPropertiesList As Variant

Utils._SetCalledSub("hasProperty")
If IsMissing(pvObject) Or IsMissing(pvProperty) Then Call _TraceArguments()

hasProperty = False
If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _
, OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _
)) Then Goto Exit_Function
If Not Utils._CheckArgument(pvProperty, 2, vbString) Then Goto Exit_Function

hasProperty = pvObject.hasProperty(pvProperty)

Exit_Function:
Utils._ResetCalledSub("hasProperty")
Exit Function
End Function ' hasProperty V0.9.0
Access2BaseDev Methods Move Basic   27
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Move(Optional pvObject As Object _
, ByVal Optional pvLeft As Variant _
, ByVal Optional pvTop As Variant _
, ByVal Optional pvWidth As Variant _
, ByVal Optional pvHeight As Variant _
) As Variant
' Execute Move method
Utils._SetCalledSub("Move")
If IsMissing(pvObject) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function
Move = False
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
If IsMissing(pvLeft) Then Call _TraceArguments()
If IsMissing(pvTop) Then pvTop = -1
If IsMissing(pvWidth) Then pvWidth = -1
If IsMissing(pvHeight) Then pvHeight = -1

Move = pvObject.Move(pvLeft, pvTop, pvWidth, pvHeight)

Exit_Function:
Utils._ResetCalledSub("Move")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Move", Erl)
GoTo Exit_Function
End Function ' Move V.0.9.1
Access2BaseDev Methods OpenHelpFile Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenHelpFile()
' Open the help file from the Help menu (IDE only)
Const cstHelpFile = "http://www.access2base.com/access2base.html"

On Local Error Resume Next
Call _ShellExecute(cstHelpFile)

End Function ' OpenHelpFile V0.8.5
Access2BaseDev Methods Properties Basic   24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Dim vProperties As Variant, oCounter As Variant, opProperty As Variant
Dim vPropertiesList() As Variant

If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
Utils._SetCalledSub("Properties")

Set vProperties = Nothing
If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _
, OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _
)) Then Goto Exit_Function

If IsMissing(pvIndex) Then vProperties = pvObject.Properties Else vProperties = pvObject.Properties(pvIndex)

Exit_Function:
Set Properties = vProperties
Utils._ResetCalledSub("Properties")
Exit Function
End Function ' Properties V0.9.0
Access2BaseDev Methods Refresh Basic   18
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Refresh(Optional pvObject As Variant) As Boolean
' Refresh data with its most recent value in the database in a form or subform
Utils._SetCalledSub("Refresh")
If IsMissing(pvObject) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function
Refresh = False
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function

Refresh = pvObject.Refresh()

Exit_Function:
Utils._ResetCalledSub("Refresh")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Refresh", Erl)
GoTo Exit_Function
End Function ' Refresh V0.9.0
Access2BaseDev Methods RemoveItem Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RemoveItem(Optional pvBox As Variant,ByVal Optional pvIndex) As Boolean
' Remove an item from a Listbox
' Index may be a string value or an index-position

Utils._SetCalledSub("RemoveItem")
If _ErrorHandler() Then On Local Error Goto Error_Function

If IsMissing(pvBox) Or IsMissing(pvIndex) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function

RemoveItem = pvBox.RemoveItem(pvIndex)

Exit_Function:
Utils._ResetCalledSub("RemoveItem")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "RemoveItem", Erl)
RemoveItem = False
GoTo Exit_Function
End Function ' RemoveItem V0.9.0
Access2BaseDev Methods Requery Basic   17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Requery(Optional pvObject As Variant) As Boolean
' Refresh data displayed in a form, subform, combobox or listbox
Utils._SetCalledSub("Requery")
If IsMissing(pvObject) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL, OBJSUBFORM)) Then Goto Exit_Function

Requery = pvObject.Requery()

Exit_Function:
Utils._ResetCalledSub("Requery")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Requery", Erl)
GoTo Exit_Function
End Function ' Requery V0.9.0
Access2BaseDev Methods SetFocus Basic   20
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SetFocus(Optional pvObject As Variant) As Boolean
' Execute SetFocus method
Utils._SetCalledSub("setFocus")
If IsMissing(pvObject) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL)) Then Goto Exit_Function

SetFocus = pvObject.setFocus()

Exit_Function:
Utils._ResetCalledSub("SetFocus")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "SetFocus", Erl)
Goto Exit_Function
Error_Grid:
TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name))
Goto Exit_Function
End Function ' SetFocus V0.9.0
Access2BaseDev Module _BeginStatement Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _BeginStatement(ByVal plStart As Long) As Long
' Return the position in _Script of the beginning of the current statement as defined by plStart

Dim sProc As String, iProc As Integer, iType As Integer
Dim lPosition As Long, lPrevious As Long, sFind As String

sProc = ProcOfLine(_LineOfPosition(plStart), iType)
iProc = _FindProcIndex(sProc, iType)
If iProc < 0 Then lPosition = 1 Else lPosition = _ProcDecPositions(iProc)

sFind = "Any"
Do While lPosition < plStart And sFind <> ""
lPrevious = lPosition
sFind = _FindPattern("%^\w", lPosition)
If sFind = "" Then Exit Do
Loop

_BeginStatement = lPrevious

End Function ' _EndStatement
Access2BaseDev Module _EndStatement Basic   11
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _EndStatement(ByVal plStart As Long) As Long
' Return the position in _Script of the end of the current statement as defined by plStart
' plStart is assumed not to be in the middle of a comment or a string

Dim sMatch As String, lPosition As Long
lPosition = plStart
sMatch = _FindPattern("%$", lPosition)
_EndStatement = lPosition

End Function ' _EndStatement
Access2BaseDev Module _FindPattern Basic _BeginStatement (Procedure)
_EndStatement (Procedure)
_ParseProcs (Procedure)
_PropertyGet (Procedure)
93
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FindPattern(ByVal psPattern As Variant, Optional ByRef plStart As Long) As String
' Find first occurrence of any of the patterns in |-delimited string psPattern
' Special escapes
' - for word breaks: "%B" (f.i. for searching "END%BFUNCTION")
' - for statement start: "%^" (f.i. for searching "%^END%BFUNCTION"). Necessarily first 2 characters of pattern
' - for statement end: "%$". Pattern should not contain anything else
' If quoted string searched, pattern should start and end with a double quote
' Return "" if none found, otherwise returns the matching string
' plStart = start position of _Script to search (starts at 1)
' In output plStart contains the first position of the matching string or is left unchanged
' To search again the same or another pattern => plStart = plStart + Len(matching string)
' Comments and strings are skipped

' Common patterns
Const cstComment = "('|\bREM\b)[^\n]*$"
Const cstString = """[^""\n]*"""
Const cstBeginStatement = "(^|:|\bthen\b|\belse\b|\n)[ \t]*"
Const cstEndStatement = "[ \t]*($|:|\bthen\b|\belse\b|\n)"
Const cstContinuation = "[ \t]_\n"
Const cstWordBreak = "\b[ \t]+(_\n[ \t]*)?\b"
Const cstAlt = "|"

Dim sRegex As String, lStart As Long, bContinue As Boolean, sMatch As String
Dim bEndStatement As Boolean, bQuote As Boolean

If psPattern = "%$" Then
sRegex = cstEndStatement
Else
sRegex = psPattern
If Left(psPattern, 2) = "%^" Then sRegex = cstBeginStatement & Right(sRegex, Len(sregex) - 2)
sregex = Replace(sregex, "%B", cstWordBreak)
End If
' Add all to ignore patterns to regex. If pattern = quoted string do not add cstString
If Len(psPattern) > 2 And Left(psPattern, 1) = """" And Right(psPattern, 1) = """" Then
bQuote = True
sRegex = sRegex & cstAlt & cstComment & cstAlt & cstContinuation
Else
bQuote = False
sRegex = sRegex & cstAlt & cstComment & cstAlt & cstString & cstAlt & cstContinuation
End If

If IsMissing(plStart) Then plStart = 1
lStart = plStart

bContinue = True
Do While bContinue
bEndStatement = False
sMatch = Utils._RegexSearch(_Script, sRegex, lStart)
Select Case True
Case sMatch = ""
bContinue = False
Case Left(sMatch, 1) = "'"
bEndStatement = True
Case Left(sMatch, 1) = """"
If bQuote Then
plStart = lStart
bContinue = False
End If
Case Left(smatch, 1) = ":" Or Left(sMatch, 1) = vbLf
If psPattern = "%$" Then
bEndStatement = True
Else
bContinue = False
plStart = lStart + 1
sMatch = Right(sMatch, Len(sMatch) - 1)
End If
Case UCase(Left(sMatch, 4)) = "REM " Or UCase(Left(sMatch, 4)) = "REM" & vbTab Or UCase(Left(sMatch, 4)) = "REM" & vbNewLine
bEndStatement = True
Case UCase(Left(sMatch, 4)) = "THEN" Or UCase(Left(sMatch, 4)) = "ELSE"
If psPattern = "%$" Then
bEndStatement = True
Else
bContinue = False
plStart = lStart + 4
sMatch = Right(sMatch, Len(sMatch) - 4)
End If
Case sMatch = " _" & vbLf
Case Else ' Found
plStart = lStart
bContinue = False
End Select
If bEndStatement And psPattern = "%$" Then
bContinue = False
plStart = lStart - 1
sMatch = ""
End If
lStart = lStart + Len(sMatch)
Loop

_FindPattern = sMatch

End Function ' _FindPattern
Access2BaseDev Module _FindProcIndex Basic ProcBodyLine (Procedure)
ProcCountLines (Procedure)
_BeginStatement (Procedure)
21
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FindProcIndex(ByVal psProc As String, ByVal piType As Integer) As Integer
' Return index of entry in _Procnames corresponding with pvProc

Dim i As Integer, iIndex As Integer

If Not _ProcsParsed Then _ParseProcs

iIndex = -1
For i = 0 To UBound(_ProcNames)
If UCase(psProc) = UCase(_ProcNames(i)) And piType = _ProcTypes(i) Then
iIndex = i
Exit For
End If
Next i
If iIndex < 0 Then TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, Utils._CalledSub(), 0, , Array(psProc, _Name))

Exit_Function:
_FindProcIndex = iIndex
Exit Function
End Function ' _FindProcIndex
Access2BaseDev Module _Initialize Basic   8
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize()

_Script = Replace(_Script, vbCr, "")
_Lines = Split(_Script, vbLf)
_CountOfLines = UBound(_Lines) + 1

End Sub ' _Initialize
Access2BaseDev Module _LineOfPosition Basic ProcBodyLine (Procedure)
ProcCountLines (Procedure)
ProcOfLine (Procedure)
Find (Procedure)
_BeginStatement (Procedure)
27
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _LineOfPosition(ByVal plPosition) As Long
' Return the line number of a position in _Script

Dim lLine As Long, lLength As Long
' Start counting from start or end depending on how close position is
If plPosition <= Len(_Script) / 2 Then
lLength = 0
For lLine = 0 To UBound(_Lines)
lLength = lLength + Len(_Lines(lLine)) + 1 ' + 1 for line feed
If lLength >= plPosition Then
_LineOfPosition = lLine + 1
Exit Function
End If
Next lLine
Else
If Right(_Script, 1) = vbLf Then lLength = Len(_Script) + 1 Else lLength = Len(_Script)
For lLine = UBound(_Lines) To 0 Step -1
lLength = lLength - Len(_Lines(lLine)) - 1 ' - 1 for line feed
If lLength <= plPosition Then
_LineOfPosition = lLine + 1
Exit Function
End If
Next lLine
End If

End Function ' _LineOfPosition
Access2BaseDev Module _ParseProcs Basic ProcOfLine (Procedure)
_FindProcIndex (Procedure)
_PropertyGet (Procedure)
54
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _ParseProcs()
' Fills the Proc arrays: name, start and end position
' Executed at first request needing this processing

Dim lPosition As Long, iProc As Integer, sDecProc As String, sEndProc As String, sNameProc As String, sType As String
Const cstDeclaration = "%^(private%B|public%B)?\b(property%Bget|property%Blet|property%Bset|function|sub)\b"
Const cstEnd = "%^end%B(property|function|sub)\b"
Const cstName = "\w*" '"[A-Za-z_][A-Za-z_0-9]*"

If _ProcsParsed Then Exit Sub ' Do not redo if already done
_ProcNames = Array()
_ProcDecPositions = Array()
_ProcEndPositions = Array()
_ProcTypes = Array()

lPosition = 1
iProc = -1
sDecProc = "???"
Do While sDecProc <> ""
' Identify Function/Sub declaration string
sDecProc = _FindPattern(cstDeclaration, lPosition)
If sDecProc <> "" Then
iProc = iProc + 1
ReDim Preserve _ProcNames(0 To iProc)
ReDim Preserve _ProcDecPositions(0 To iProc)
ReDim Preserve _ProcEndPositions(0 To iProc)
ReDim Preserve _ProcTypes(0 To iProc)
_ProcDecPositions(iProc) = lPosition
lPosition = lPosition + Len(sDecProc)
' Identify procedure type
Select Case True
Case InStr(UCase(sDecProc), "FUNCTION") > 0 : _ProcTypes(iProc) = vbext_pk_Proc
Case InStr(UCase(sDecProc), "SUB") > 0 : _ProcTypes(iProc) = vbext_pk_Proc
Case InStr(UCase(sDecProc), "GET") > 0 : _ProcTypes(iProc) = vbext_pk_Get
Case InStr(UCase(sDecProc), "LET") > 0 : _ProcTypes(iProc) = vbext_pk_Let
Case InStr(UCase(sDecProc), "SET") > 0 : _ProcTypes(iProc) = vbext_pk_Set
End Select
' Identify name of Function/Sub
sNameProc = _FindPattern(cstName, lPosition)
If sNameProc = "" Then Exit Do ' Should never happen
_ProcNames(iProc) = sNameProc
lPosition = lPosition + Len(sNameProc)
' Identify End statement
sEndProc = _FindPattern(cstEnd, lPosition)
If sEndProc = "" Then Exit Do ' Should never happen
_ProcEndPositions(iProc) = lPosition
lPosition = lPosition + Len(sEndProc)
End If
Loop

_ProcsParsed = True

End Sub
Access2BaseDev Module _PositionOfLine Basic Find (Procedure) 22
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PositionOfLine(ByVal plLine) As Long
' Return the position of the first character of the given line in _Script

Dim lLine As Long, lPosition As Long
' Start counting from start or end depending on how close line is
If plLine <= (UBound(_Lines) + 1) / 2 Then
lPosition = 0
For lLine = 0 To plLine - 1
lPosition = lPosition + 1 ' + 1 for line feed
If lLine < plLine - 1 Then lPosition = lPosition + Len(_Lines(lLine))
Next lLine
Else
lPosition = Len(_Script) + 2 ' Anticipate an ending null-string and a line feed
For lLine = UBound(_Lines) To plLine - 1 Step -1
lPosition = lPosition - Len(_Lines(lLine)) - 1 ' - 1 for line feed
Next lLine
End If

_PositionOfLine = lPosition

End Function ' _LineOfPosition
Access2BaseDev Module _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
6
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

_PropertiesList = Array("CountOfDeclarationLines", "CountOfLines", "Name", "ObjectType", "Type")

End Function ' _PropertiesList
Access2BaseDev Module _PropertyGet Basic CountOfDeclarationLines (Procedure)
CountOfLines (Procedure)
Name (Procedure)
ObjectType (Procedure)
Properties (Procedure)
pType (Procedure)
getProperty (Procedure)
48
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

Dim cstThisSub As String
Const cstDot = "."

Dim sText As String

If _ErrorHandler() Then On Local Error Goto Error_Function
cstThisSub = "Module.get" & psProperty
Utils._SetCalledSub(cstThisSub)
_PropertyGet = Null

Select Case UCase(psProperty)
Case UCase("CountOfDeclarationLines")
If Not _ProcsParsed Then _ParseProcs()
If UBound(_ProcNames) >= 0 Then
_PropertyGet = ProcStartLine(_ProcNames(0), _ProcTypes(0)) - 1
Else
_PropertyGet = _CountOfLines
End If
Case UCase("CountOfLines")
_PropertyGet = _CountOfLines
Case UCase("Name")
_PropertyGet = _Storage & cstDot & _LibraryName & cstDot & _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Type")
' Find option statement before any procedure declaration
sText = _FindPattern("%^option%Bclassmodule\b|\bfunction\b|\bsub\b|\bproperty\b")
If UCase(Left(sText, 6)) = "OPTION" Then _PropertyGet = acClassModule Else _PropertyGet = acStandardModule
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Module._PropertyGet", Erl)
_PropertyGet = Null
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Module Class_Initialize Basic Class_Terminate (Procedure) 17
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJMODULE
_Name = ""
Set _Library = Nothing
_LibraryName = ""
_Storage = ""
_Script = ""
_Lines = Array()
_CountOfLines = 0
_ProcsParsed = False
_ProcNames = Array()
_ProcDecPositions = Array()
_ProcEndPositions = Array()
End Sub ' Constructor
Access2BaseDev Module Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Module CountOfDeclarationLines Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get CountOfDeclarationLines() As Long
CountOfDeclarationLines = _PropertyGet("CountOfDeclarationLines")
End Property ' CountOfDeclarationLines (get)
Access2BaseDev Module CountOfLines Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get CountOfLines() As Long
CountOfLines = _PropertyGet("CountOfLines")
End Property ' CountOfLines (get)
Access2BaseDev Module Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Module Find Basic   106
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Find(Optional ByVal pvTarget As Variant _
, Optional ByRef pvStartLine As Variant _
, Optional ByRef pvStartColumn As Variant _
, Optional ByRef pvEndLine As Variant _
, Optional ByRef pvEndColumn As Variant _
, Optional ByVal pvWholeWord As Boolean _
, Optional ByVal pvMatchCase As Boolean _
, Optional ByVal pvPatternSearch As Boolean _
) As Boolean
' Finds specified text in the module
' xxLine and xxColumn arguments are mainly to return the position of the found string
' If they are initialized but nonsense, the function returns False

Const cstThisSub = "Module.Find"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function

Dim bFound As Boolean, lPosition As Long, lStartLine As Long, lStartColumn As Long, lStartPosition As Long
Dim lEndLine As Long, lEndColumn As Long, lEndPosition As Long
Dim sMatch As String, vOptions As Variant, sPattern As String
Dim i As Integer, sSpecChar As String

Const cstSpecialCharacters = "\[^$.|?*+()"

bFound = False

If IsMissing(pvTarget) Or IsMissing(pvStartLine) Or IsMissing(pvStartColumn) Or IsMissing(pvEndLine) Or IsMissing(pvEndColumn) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvTarget, 1, vbString) Then GoTo Exit_Function
If Len(pvTarget) = 0 Then GoTo Exit_Function
If Not IsEmpty(pvStartLine) Then
If Not Utils._CheckArgument(pvStartLine, 2, _AddNumeric()) Then GoTo Exit_Function
End If
If Not IsEmpty(pvStartColumn) Then
If Not Utils._CheckArgument(pvStartColumn, 3, _AddNumeric()) Then GoTo Exit_Function
End If
If Not IsEmpty(pvEndLine) Then
If Not Utils._CheckArgument(pvEndLine, 4, _AddNumeric()) Then GoTo Exit_Function
End If
If Not IsEmpty(pvEndColumn) Then
If Not Utils._CheckArgument(pvEndColumn, 5, _AddNumeric()) Then GoTo Exit_Function
End If
If IsMissing(pvWholeWord) Then pvWholeWord = False
If Not Utils._CheckArgument(pvWholeWord, 6, vbBoolean) Then GoTo Exit_Function
If IsMissing(pvMatchCase) Then pvMatchCase = False
If Not Utils._CheckArgument(pvMatchCase, 7, vbBoolean) Then GoTo Exit_Function
If IsMissing(pvPatternSearch) Then pvPatternSearch = False
If Not Utils._CheckArgument(pvPatternSearch, 8, vbBoolean) Then GoTo Exit_Function

' Initialize starting values
If IsEmpty(pvStartLine) Then lStartLine = 1 Else lStartLine = pvStartLine
If lStartLine <= 0 Or lStartLine > UBound(_Lines) + 1 Then GoTo Exit_Function
If IsEmpty(pvStartColumn) Then lStartColumn = 1 Else lStartColumn = pvStartColumn
If lStartColumn <= 0 Then GoTo Exit_Function
If lStartColumn > 1 And lStartColumn > Len(_Lines(lStartLine + 1)) Then GoTo Exit_Function
lStartPosition = _PositionOfLine(lStartline) + lStartColumn - 1
If IsEmpty(pvEndLine) Then lEndLine = UBound(_Lines) + 1 Else lEndLine = pvEndLine
If lEndLine < lStartLine Or lEndLine > UBound(_Lines) + 1 Then GoTo Exit_Function
If IsEmpty(pvEndColumn) Then lEndColumn = Len(_Lines(lEndLine - 1)) Else lEndColumn = pvEndColumn
If lEndColumn < 0 Then GoTo Exit_Function
If lEndColumn = 0 Then lEndColumn = 1
If lEndColumn > Len(_Lines(lEndLine - 1)) + 1 Then GoTo Exit_Function
lEndPosition = _PositionOfLine(lEndline) + lEndColumn - 1

If pvMatchCase Then
Set vOptions = _A2B_.SearchOptions
vOptions.transliterateFlags = 0
End If

' Define pattern to search for
sPattern = pvTarget
' Protect special characters in regular expressions
For i = 1 To Len(cstSpecialCharacters)
sSpecChar = Mid(cstSpecialCharacters, i, 1)
sPattern = Replace(sPattern, sSpecChar, "\" & sSpecChar)
Next i
If pvPatternSearch Then sPattern = Replace(Replace(sPattern, "\*", ".*"), "\?", ".")
If pvWholeWord Then sPattern = "\b" & sPattern & "\b"

lPosition = lStartPosition
sMatch = Utils._RegexSearch(_Script, sPattern, lPosition)
' Re-establish default options for later searches
If pvMatchCase Then vOptions.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE

' Found within requested bounds ?
If sMatch <> "" And lPosition >= lStartPosition And lPosition <= lEndPosition Then
pvStartLine = _LineOfPosition(lPosition)
pvStartColumn = lPosition - _PositionOfLine(pvStartLine) + 1
pvEndLine = _LineOfPosition(lPosition + Len(sMatch) - 1)
If pvEndLine > pvStartLine Then
pvEndColumn = lPosition + Len(sMatch) - 1 - _PositionOfLine(pvEndLine)
Else
pvEndColumn = pvStartColumn + Len(sMatch) - 1
End If
bFound = True
End If

Exit_Function:
Find = bFound
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Module.Find", Erl)
bFound = False
GoTo Exit_Function
End Function ' Find
Access2BaseDev Module getProperty Basic   12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Const cstThisSub = "Module.Properties"

Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub(cstThisSub)

End Function ' getProperty
Access2BaseDev Module hasProperty Basic   12
REM --------------------------------Mid(a._Script, iCtl, 25)---------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)

Const cstThisSub = "Module.hasProperty"

Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
Utils._ResetCalledSub(cstThisSub)
Exit Function

End Function ' hasProperty
Access2BaseDev Module Lines Basic   26
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Lines(Optional ByVal pvLine As Variant, Optional ByVal pvNumLines As Variant) As String
' Returns a string containing the contents of a specified line or lines in a standard module or a class module

Const cstThisSub = "Module.Lines"
Utils._SetCalledSub(cstThisSub)

Dim sLines As String, lLine As Long
sLines = ""

If IsMissing(pvLine) Or IsMissing(pvNumLines) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
If Not Utils._CheckArgument(pvNumLines, 1, _AddNumeric()) Then GoTo Exit_Function

lLine = pvLine
Do While lLine < _CountOfLines And lLine < pvLine + pvNumLines
sLines = sLines & _Lines(lLine - 1) & vbLf
lLine = lLine + 1
Loop
If Len(sLines) > 0 Then sLines = Left(sLines, Len(sLines) - 1)

Exit_Function:
Lines = sLines
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Lines
Access2BaseDev Module Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Module ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Module ProcBodyLine Basic ProcStartLine (Procedure) 20
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcBodyLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
' Return the number of the line at which the body of a specified procedure begins

Const cstThisSub = "Module.ProcBodyLine"
Utils._SetCalledSub(cstThisSub)

Dim iIndex As Integer

If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

iIndex = _FindProcIndex(pvProc, pvProcType)
If iIndex >= 0 Then ProcBodyLine = _LineOfPosition(_ProcDecPositions(iIndex)) Else ProcBodyLine = iIndex

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' ProcBodyline
Access2BaseDev Module ProcCountLines Basic   22
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcCountLines(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
' Return the number of lines in the specified procedure

Const cstThisSub = "Module.ProcCountLines"
Utils._SetCalledSub(cstThisSub)

Dim iIndex As Integer, lStart As Long, lEnd As Long

If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

iIndex = _FindProcIndex(pvProc, pvProcType)
lStart = ProcStartLine(pvProc, pvProcType)
lEnd = _LineOfPosition(_ProcEndPositions(iIndex))
ProcCountLines = lEnd - lStart + 1

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' ProcCountLines
Access2BaseDev Module ProcOfLine Basic _BeginStatement (Procedure) 35
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcOfLine(Optional ByVal pvLine As Variant, Optional ByRef pvProcType As Variant) As String
' Return the name and type of the procedure containing line pvLine

Const cstThisSub = "Module.ProcOfLine"
Utils._SetCalledSub(cstThisSub)

Dim sProcedure As String, iProc As Integer, lLineDec As Long, lLineEnd As Long

If IsMissing(pvLine) Or IsMissing(pvProcType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

If Not _ProcsParsed Then _ParseProcs()

sProcedure = ""
For iProc = 0 To UBound(_ProcNames)
lLineEnd = _LineOfPosition(_ProcEndPositions(iProc))
If pvLine <= lLineEnd Then
lLineDec = _LineOfPosition(_ProcDecPositions(iProc))
If pvLine < lLineDec Then ' Line between 2 procedures
sProcedure = ""
Else
sProcedure = _ProcNames(iProc)
pvProcType = _ProcTypes(iProc)
End If
Exit For
End If
Next iProc

Exit_Function:
ProcOfLine = sProcedure
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' ProcOfline
Access2BaseDev Module ProcStartLine Basic ProcCountLines (Procedure)
_PropertyGet (Procedure)
32
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcStartLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
' Return the number of the line at which the specified procedure begins

Const cstThisSub = "Module.ProcStartLine"
Utils._SetCalledSub(cstThisSub)

Dim lLine As Long, lIndex As Long, sLine As String

If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

lLine = ProcBodyLine(pvProc, pvProcType)
' Search baclIndexward for comment lines
lIndex = lLine - 1
Do While lIndex > 0
sLine = _Trim(_Lines(lIndex - 1))
If UCase(Left(sLine, 4)) = "REM " Or Left(sLine, 1) = "'" Then
lLine = lIndex
Else
Exit Do
End If
lIndex = lIndex - 1
Loop

ProcStartLine = lLine

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' ProcStartLine
Access2BaseDev Module Properties Basic   25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Const cstThisSub = "Module.Properties"
Utils._SetCalledSub(cstThisSub)

Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String

vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Properties
Access2BaseDev Module pType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get pType() As String
pType = _PropertyGet("Type")
End Property ' Type (get)
Access2BaseDev OptionGroup _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
9
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

_PropertiesList = Array("Count", "Name", "ObjectType", "Value")

End Function ' _PropertiesList
Access2BaseDev OptionGroup _PropertyGet Basic Count (Procedure)
Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
Properties (Procedure)
Value (Procedure)
getProperty (Procedure)
47
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("OptionGroup.get" & psProperty)

'Execute
Dim oDatabase As Object, vBookmark As Variant
Dim iValue As Integer, i As Integer
_PropertyGet = EMPTY
Select Case UCase(psProperty)
Case UCase("Count")
_PropertyGet = _Count
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Value")
iValue = -1
For i = 0 To _Count - 1 ' Find the selected RadioButton
If _ButtonsGroup(i).State = 1 Then
iValue = _ButtonsIndex(i)
Exit For
End If
Next i
_PropertyGet = iValue
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("OptionGroup.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "OptionGroup._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev OptionGroup _PropertySet Basic Value (Procedure)
setProperty (Procedure)
46
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean

Utils._SetCalledSub("OptionGroup.set" & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function
_PropertySet = True

'Execute
Dim i As Integer, iRadioIndex As Integer, oModel As Object, iArgNr As Integer

If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2
Select Case UCase(psProperty)
Case UCase("Value")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 0 Or pvValue > _Count - 1 Then Goto Trace_Error_Value
For i = 0 To _Count - 1
_ButtonsGroup(i).State = 0
If _ButtonsIndex(i) = pvValue Then iRadioIndex = i
Next i
_ButtonsGroup(iRadioIndex).State = 1
Set oModel = _ButtonsGroup(iRadioIndex)
If Utils._hasUNOProperty(oModel, "DataField") Then
If Not IsNull(oModel.Datafield) And Not IsEmpty(oModel.Datafield) Then
If oModel.Datafield <> "" And Utils._hasUNOMethod(oModel, "commit") Then oModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM]
End If
End If
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("OptionGroup.set" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "OptionGroup._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev OptionGroup Class_Initialize Basic Class_Terminate (Procedure) 14
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJOPTIONGROUP
_Name = ""
_ParentType = ""
_ParentComponent = Nothing
_DocEntry = -1
_DbEntry = -1
_ButtonsGroup = Array()
_ButtonsIndex = Array()
_Count = 0
End Sub ' Constructor
Access2BaseDev OptionGroup Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev OptionGroup Controls Basic   68
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
' Return a Control object with name or index = pvIndex

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("OptionGroup.Controls")

Dim ocControl As Variant, iArgNr As Integer, i As Integer

Set ocControl = Nothing

If IsMissing(pvIndex) Then ' No argument, return Collection object
Set oCounter = New Collect
oCounter._SubType = OBJCONTROL
oCounter._ParentType = OBJOPTIONGROUP
oCounter._ParentName = _Name
oCounter._Count = _Count
Set Controls = oCounter
Goto Exit_Function
End If

If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2
If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
If pvIndex < 0 Or pvIndex > _Count - 1 Then Goto Trace_Error_Index

' Start building the ocControl object
' Determine exact name
Set ocControl = New Control
ocControl._ParentType = CTLPARENTISGROUP

ocControl._Shortcut = ""
For i = 0 To _Count - 1
If _ButtonsIndex(i) = pvIndex Then
Set ocControl.ControlModel = _ButtonsGroup(i)
Select Case _ParentType
Case CTLPARENTISDIALOG : ocControl._Name = _ButtonsGroup(i).Name
Case Else : ocControl._Name = _Name ' OptionGroup and individual radio buttons share the same name
End Select
ocControl._ImplementationName = ocControl.ControlModel.getImplementationName()
Exit For
End If
Next i
ocControl._FormComponent = _ParentComponent
ocControl._ClassId = acRadioButton
Select Case _ParentType
Case CTLPARENTISDIALOG : Set ocControl.ControlView = _ParentComponent.getControl(ocControl._Name)
Case Else : Set ocControl.ControlView = _ParentComponent.CurrentController.getControl(ocControl.ControlModel)
End Select

ocControl._Initialize()
ocControl._DocEntry = _DocEntry
ocControl._DbEntry = _DbEntry
Set Controls = ocControl

Exit_Function:
Utils._ResetCalledSub("OptionGroup.Controls")
Exit Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set Controls = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "OptionGroup.Controls", Erl)
Set Controls = Nothing
GoTo Exit_Function
End Function ' Controls
Access2BaseDev OptionGroup Count Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Count() As Variant
Count = _PropertyGet("Count")
End Property ' Count (get)
Access2BaseDev OptionGroup Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev OptionGroup getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("OptionGroup.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("OptionGroup.getProperty")

End Function ' getProperty
Access2BaseDev OptionGroup hasProperty Basic   8
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
Access2BaseDev OptionGroup Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev OptionGroup ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev OptionGroup pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev OptionGroup Properties Basic   20
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, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev OptionGroup setProperty Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Utils._SetCalledSub("OptionGroup.setProperty")
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub("OptionGroup.setProperty")
End Function
Access2BaseDev OptionGroup Value Basic   7
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)
Access2BaseDev PropertiesGet _getProperty Basic getAbsolutePosition (Procedure)
getAllowAdditions (Procedure)
getAllowDeletions (Procedure)
getAllowEdits (Procedure)
getBackColor (Procedure)
getBeginGroup (Procedure)
getBOF (Procedure)
getBookmark (Procedure)
getBookmarkable (Procedure)
getBorderColor (Procedure)
getBorderStyle (Procedure)
getBuiltIn (Procedure)
getButtonLeft (Procedure)
getButtonMiddle (Procedure)
getButtonRight (Procedure)
getCancel (Procedure)
getCaption (Procedure)
getClickCount (Procedure)
getContextShortcut (Procedure)
getControlSource (Procedure)
getControlTipText (Procedure)
getControlType (Procedure)
getCount (Procedure)
getCurrentRecord (Procedure)
getDataType (Procedure)
getDbType (Procedure)
getDefault (Procedure)
getDefaultValue (Procedure)
getDescription (Procedure)
getEditMode (Procedure)
getEnabled (Procedure)
getEOF (Procedure)
getEventName (Procedure)
getEventType (Procedure)
getFieldSize (Procedure)
getFilter (Procedure)
getFilterOn (Procedure)
getFocusChangeTemporary (Procedure)
getFontBold (Procedure)
getFontItalic (Procedure)
getFontName (Procedure)
getFontSize (Procedure)
getFontUnderline (Procedure)
getFontWeight (Procedure)
getForm (Procedure)
getFormat (Procedure)
getHeight (Procedure)
getForeColor (Procedure)
getIsLoaded (Procedure)
getItemData (Procedure)
getKeyAlt (Procedure)
getKeyChar (Procedure)
getKeyCode (Procedure)
getKeyCtrl (Procedure)
getKeyFunction (Procedure)
getKeyShift (Procedure)
getLinkChildFields (Procedure)
getLinkMasterFields (Procedure)
getListCount (Procedure)
getListIndex (Procedure)
getLocked (Procedure)
getMultiSelect (Procedure)
getName (Procedure)
getObjectType (Procedure)
getOpenArgs (Procedure)
getOptionValue (Procedure)
getOrderBy (Procedure)
getOrderByOn (Procedure)
getPage (Procedure)
getParent (Procedure)
getProperty (Procedure)
getRecommendation (Procedure)
getRecordCount (Procedure)
getRecordset (Procedure)
getRecordSource (Procedure)
getRequired (Procedure)
getRowChangeAction (Procedure)
getRowSource (Procedure)
getRowSourceType (Procedure)
getSelected (Procedure)
getSize (Procedure)
getSource (Procedure)
getSourceField (Procedure)
getSourceTable (Procedure)
getSpecialEffect (Procedure)
getSubType (Procedure)
getSubComponentName (Procedure)
getSubComponentType (Procedure)
getTabIndex (Procedure)
getTabStop (Procedure)
getTag (Procedure)
getText (Procedure)
getTextAlign (Procedure)
getTooltipText (Procedure)
getTripleState (Procedure)
getTypeName (Procedure)
getVisible (Procedure)
getWidth (Procedure)
getXPos (Procedure)
getYPos (Procedure)
350
Public Function _getProperty(pvItem As Variant, ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant
' Return property value of the psProperty property name within object pvItem

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("get" & psProperty)
_getProperty = Nothing

'pvItem must be an object and have the requested property
If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function
If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error
'Check Index argument
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 3, Utils._AddNumeric()) Then Goto Exit_Function
End If
'Execute
Select Case UCase(psProperty)
Case UCase("AbsolutePosition")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
_getProperty = pvItem.AbsolutePosition
Case UCase("AllowAdditions")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.AllowAdditions
Case UCase("AllowDeletions")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.AllowDeletions
Case UCase("AllowEdits")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.AllowEdits
Case UCase("BackColor")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.BackColor
Case UCase("BeginGroup")
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
_getProperty = pvItem.BeginGroup
Case UCase("BOF")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
_getProperty = pvItem.BOF
Case UCase("Bookmark")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function
_getProperty = pvItem.Bookmark
Case UCase("Bookmarkable")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
_getProperty = pvItem.Bookmarkable
Case UCase("BorderColor")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.BorderColor
Case UCase("BorderStyle")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.BorderStyle
Case UCase("BuiltIn")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function
_getProperty = pvItem.BuiltIn
Case UCase("ButtonLeft")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.ButtonLeft
Case UCase("ButtonMiddle")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.ButtonMiddle
Case UCase("ButtonRight")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.ButtonRight
Case UCase("Cancel")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Cancel
Case UCase("Caption")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function
_getProperty = pvItem.Caption
Case UCase("ClickCount")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.ClickCount
Case UCase("ContextShortcut")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.ContextShortcut
Case UCase("ControlSource")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.ControlSource
Case UCase("ControlTipText")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.ControlTipText
Case UCase("ControlType")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.ControlType
Case UCase("Count")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCOLLECTION,OBJOPTIONGROUP)) Then Goto Exit_Function
_getProperty = pvItem.Count
Case UCase("CurrentRecord")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.CurrentRecord
Case UCase("DataType")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.DataType
Case UCase("DbType")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.DbType
Case UCase("Default")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Default
Case UCase("DefaultValue")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function
_getProperty = pvItem.DefaultValue
Case UCase("Description")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.Description
Case UCase("EditMode")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
_getProperty = pvItem.EditMode
Case UCase("Enabled")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Enabled
Case UCase("EOF")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
_getProperty = pvItem.EOF
Case UCase("EventName")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.EventName
Case UCase("EventType")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.EventType
Case UCase("FieldSize")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.FieldSize
Case UCase("Filter")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function
_getProperty = pvItem.Filter
Case UCase("FilterOn")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.FilterOn
Case UCase("FocusChangeTemporary")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.FocusChangeTemporary
Case UCase("FontBold")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.FontBold
Case UCase("FontItalic")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.FontItalic
Case UCase("FontName")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.FontName
Case UCase("FontSize")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.FontSize
Case UCase("FontUnderline")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.FontUnderline
Case UCase("FontWeight")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.FontWeight
Case UCase("ForeColor")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.ForeColor
Case UCase("Form")
If Not Utils._CheckArgument(pvItem, 1, CTLSUBFORM) Then Goto Exit_Function
_getProperty = pvItem.Form
Case UCase("Format")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Format
Case UCase("Height")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
_getProperty = pvItem.Height
Case UCase("Index")
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Index
Case UCase("IsLoaded")
If Not Utils._CheckArgument(pvItem, 1, OBJFORM) Then Goto Exit_Function
_getProperty = pvItem.IsLoaded
Case UCase("ItemData")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
If IsMissing(pvIndex) Then _getProperty = pvItem.ItemData Else _getProperty = pvItem.ItemData(pvIndex)
Case UCase("KeyAlt")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.KeyAlt
Case UCase("KeyChar")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.KeyChar
Case UCase("KeyCode")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.KeyCode
Case UCase("KeyCtrl")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.KeyCtrl
Case UCase("KeyFunction")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.KeyFunction
Case UCase("KeyShift")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.KeyShift
Case UCase("LinkChildFields")
If Not Utils._CheckArgument(pvItem, 1, OBJSUBFORM) Then Goto Exit_Function
If IsMissing(pvIndex) Then _getProperty = pvItem.LinkChildFields Else _getProperty = pvItem.LinkChildFields(pvIndex)
Case UCase("LinkMasterFields")
If Not Utils._CheckArgument(pvItem, 1, OBJSUBFORM) Then Goto Exit_Function
If IsMissing(pvIndex) Then _getProperty = pvItem.LinkMasterFields Else _getProperty = pvItem.LinkMasterFields(pvIndex)
Case UCase("ListCount")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.ListCount
Case UCase("ListIndex")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.ListIndex
Case UCase("Locked")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
If IsNull(pvItem.Locked) Then Goto Trace_Error
_ge ExitProperty = pvItem.Locked
Case UCase("MultiSelect")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.MultiSelect
Case UCase("Name")
If Not Utils._CheckArgument(pvItem, 1, _
Array(OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJDIALOG, OBJTABLEDEF, OBJRECORDSET, OBJFIELD, OBJTEMPVAR, OBJCOMMANDBAR) _
) Then Goto Exit_Function
_getProperty = pvItem.Name
Case UCase("ObjectType")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJDATABASE, OBJCOLLECTION, OBJFORM, OBJDIALOG, OBJSUBFORM, OBJCONTROL _
, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY, OBJRECORDSET, OBJTABLEDEF, OBJFIELD, OBJTEMPVAR _
, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL) _
) Then Goto Exit_Function
_getProperty = pvItem.ObjectType
Case UCase("OnAction")
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
_getProperty = pvItem.OnAction
Case UCase("OpenArgs")
If Not Utils._CheckArgument(pvItem, 1, OBJFORM) Then Goto Exit_Function
_getProperty = pvItem.OpenArgs
Case UCase("OptionValue")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.OptionValue
Case UCase("OrderBy")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.OrderBy
Case UCase("OrderByOn")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.OrderByOn
Case UCase("Page")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function
_getProperty = pvItem.Page
Case UCase("Parent")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJSUBFORM, OBJCONTROL, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function
_getProperty = pvItem.Parent
Case UCase("Recommendation")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.Recommendation
Case UCase("RecordCount")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
_getProperty = pvItem.RecordCount
Case UCase("Recordset")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.Recordset
Case UCase("RecordSource")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
_getProperty = pvItem.RecordSource
Case UCase("Required")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Required
Case UCase("RowChangeAction")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.RowChangeAction
Case UCase("RowSource")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.RowSource
Case UCase("RowSourceType")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.RowSourceType
Case UCase("Selected")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
If IsMissing(pvIndex) Then _getProperty = pvItem.Selected Else _getProperty = pvItem.Selected(pvIndex)
Case UCase("Size")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.Size
Case UCase("Source")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.Source
Case UCase("SourceTable")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.SourceTable
Case UCase("SourceField")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.SourceField
Case UCase("SpecialEffect")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.SpecialEffect
Case UCase("SubComponentName")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.SubComponentName
Case UCase("SubComponentType")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
_getProperty = pvItem.SubComponentType
Case UCase("SubType")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.SubType
Case UCase("TabIndex")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.TabIndex
Case UCase("TabStop")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.TabStop
Case UCase("Tag")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Tag
Case UCase("Text")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.Text
Case UCase("TextAlign")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.TextAlign
Case UCase("TooltipText")
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
_getProperty = pvItem.TooltipText
Case UCase("TripleState")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
_getProperty = pvItem.TripleState
Case UCase("TypeName")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
_getProperty = pvItem.TypeName
Case UCase("Value")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function
_getProperty = pvItem.Value
Case UCase("Visible")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function
_getProperty = pvItem.Visible
Case UCase("Width")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
_getProperty = pvItem.Width
Case UCase("XPos")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
If IsNull(pvItem.XPos) Then Goto Trace_Error
_getProperty = pvItem.XPos
Case UCase("YPos")
If Not Utils._CheckArgument(pvItem, 1, OBJEVENT) Then Goto Exit_Function
If IsNull(pvItem.YPos) Then Goto Trace_Error
_getProperty = pvItem.YPos
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_getProperty = Nothing
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
_getProperty = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "_getProperty", Erl)
_getProperty = Nothing
GoTo Exit_Function
End Function ' _getProperty V0.9.1
Access2BaseDev PropertiesGet _hasProperty Basic hasProperty (Procedure)
_setProperty (Procedure)
hasProperty (Procedure)
_getProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
hasProperty (Procedure)
19
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasProperty(ByVal psObject As String, ByVal pvPropertiesList() As Variant, ByVal pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
' Generic hasProperty function called from all class modules

Dim sObject As String
sObject = Utils._PCase(psObject)
Utils._SetCalledSub(sObject & ".hasProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()

_hasProperty = False
If Not Utils._CheckArgument(pvProperty, 1, vbString) Then Goto Exit_Function

_hasProperty = Utils._InList(pvProperty, pvPropertiesList(), , True)

Exit_Function:
Utils._ResetCalledSub(sObject & ".hasProperty")
Exit Function
End Function ' _hasProperty
Access2BaseDev PropertiesGet _ParentObject Basic Parent (Procedure)
_PropertyGet (Procedure)
22
REM ------------------------------------------------------------------------------------------------------------------------
Public Function _ParentObject(psShortcut As String) As Object
' Return parent object from shortcut as a string

Dim sParent As String, vParent() As Variant, iBound As Integer
vParent = Split(psShortcut, "!")
iBound = UBound(vParent) - 1
ReDim Preserve vParent(0 To iBound) ' Remove last element
sParent = Join(vParent, "!")

'Remove ".Form" if present
Const cstForm = ".FORM"
Set _ParentObject = Nothing
If Len(sParent) > Len(cstForm) Then
If UCase(Right(sParent, Len(cstForm))) = cstForm Then
Set _ParentObject = getValue(sParent)
Else
Set _ParentObject = getObject(sParent)
End If
End If

End Function ' _ParentObject V0.9.0
Access2BaseDev PropertiesGet _Properties Basic Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
46
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Properties(ByVal psObject As String _
, ByVal psObjectName As String _
, ByVal pvPropertiesList() As Variant _
, ByVal Optional pvIndex As Variant _
) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise
' Generic function called from Properties methods stored in classes

Dim vProperties As Variant, oCounter As Object, opProperty As Object
Dim iArgNr As Integer, iLen As Integer

Utils._SetCalledSub(psObject & ".Properties")

vProperties = Null

If IsMissing(pvIndex) Then ' Call without index argument prepares a Collection object
Set oCounter = New Collect
oCounter._CollType = COLLPROPERTIES
oCounter._ParentType = UCase(psObject)
oCounter._ParentName = psObjectName
oCounter._Count = UBound(pvPropertiesList) + 1
Set vProperties = oCounter
Else
iLen = Len(psObject) + 1
If Len(_A2B_.CalledSub) > iLen Then
If Left(_A2B_.CalledSub, iLen) = psObject & "." Then iArgNr = 1 Else iArgNr = 2
End If
If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
If pvIndex < LBound(pvPropertiesList) Or pvIndex > UBound(pvPropertiesList) Then
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Else
Set opProperty = New Property
opProperty._Name = pvPropertiesList(pvIndex)
opProperty._Value = Null
Set vProperties = opProperty
End If
End If

Exit_Function:
Set _Properties = vProperties
Utils._ResetCalledSub(psObject & ".Properties")
Exit Function
End Function ' _Properties
Access2BaseDev PropertiesGet _PropertiesList Basic   21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _PropertiesList(pvObject As Variant) As Variant
' Return an array of strings containing the list of valid properties of pvObject

Dim vProperties As Variant
Dim vPropertiesList As Variant, bPropertiesList() As Boolean, sPropertiesList() As String
Dim i As Integer, j As Integer, iCount As Integer

Set vProperties = Nothing
Select Case pvObject._Type
Case OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJEVENT, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _
, OBJDATABASE, OBJTABLEDEF, OBJQUERYDEF, OBJDIALOG, OBJFIELD, OBJRECORDSET, OBJTEMPVAR _
, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL
vPropertiesList = pvObject._PropertiesList()
Case Else
End Select

Exit_Function:
Set _PropertiesList = vPropertiesList
Exit Function
End Function ' PropertiesList V0.9.0
Access2BaseDev PropertiesGet getAbsolutePosition Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getAbsolutePosition(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAbsolutePosition")
getAbsolutePosition = PropertiesGet._getProperty(pvObject, "AbsolutePosition")
End Function ' getAbsolutePosition
Access2BaseDev PropertiesGet getAllowAdditions Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getAllowAdditions(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowAdditions")
getAllowAdditions = PropertiesGet._getProperty(pvObject, "AllowAdditions")
End Function ' getAllowAdditions
Access2BaseDev PropertiesGet getAllowDeletions Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getAllowDeletions(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowDeletions")
getAllowDeletions = PropertiesGet._getProperty(pvObject, "AllowDeletions")
End Function ' getAllowDeletions
Access2BaseDev PropertiesGet getAllowEdits Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getAllowEdits(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getAllowEdits")
getAllowEdits = PropertiesGet._getProperty(pvObject, "AllowEdits")
End Function ' getAllowEdits
Access2BaseDev PropertiesGet getBackColor Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBackColor(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBackColor")
getBackColor = PropertiesGet._getProperty(pvObject, "BackColor")
End Function ' getBackColor
Access2BaseDev PropertiesGet getBeginGroup Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBeginGroup(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBeginGroup")
getBeginGroup = PropertiesGet._getProperty(pvObject, "BeginGroup")
End Function ' getBeginGroup
Access2BaseDev PropertiesGet getBOF Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBOF(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBOF")
getBOF = PropertiesGet._getProperty(pvObject, "BOF")
End Function ' getBOF
Access2BaseDev PropertiesGet getBookmark Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBookmark(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBookmark")
getBookmark = PropertiesGet._getProperty(pvObject, "Bookmark")
End Function ' getBookmark
Access2BaseDev PropertiesGet getBookmarkable Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBookmarkable(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBookmarkable")
getBookmarkable = PropertiesGet._getProperty(pvObject, "Bookmarkable")
End Function ' getBookmarkable
Access2BaseDev PropertiesGet getBorderColor Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBorderColor(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBorderColor")
getBorderColor = PropertiesGet._getProperty(pvObject, "BorderColor")
End Function ' getBorderColor
Access2BaseDev PropertiesGet getBorderStyle Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBorderStyle(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBorderStyle")
getBorderStyle = PropertiesGet._getProperty(pvObject, "BorderStyle")
End Function ' getBorderStyle
Access2BaseDev PropertiesGet getBuiltIn Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getBuiltIn(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getBuiltIn")
getBuiltIn = PropertiesGet._getProperty(pvObject, "BuiltIn")
End Function ' getBuiltIn
Access2BaseDev PropertiesGet getButtonLeft Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getButtonLeft(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonLeft")
getButtonLeft = PropertiesGet._getProperty(pvObject, "ButtonLeft")
End Function ' getButtonLeft
Access2BaseDev PropertiesGet getButtonMiddle Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getButtonMiddle(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonMiddle")
getButtonMiddle = PropertiesGet._getProperty(pvObject, "ButtonMiddle")
End Function ' getButtonMiddle
Access2BaseDev PropertiesGet getButtonRight Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getButtonRight(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getButtonRight")
getButtonRight = PropertiesGet._getProperty(pvObject, "ButtonRight")
End Function ' getButtonRight
Access2BaseDev PropertiesGet getCancel Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getCancel(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCancel")
getCancel = PropertiesGet._getProperty(pvObject, "Cancel")
End Function ' getCancel
Access2BaseDev PropertiesGet getCaption Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getCaption(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCaption")
getCaption = PropertiesGet._getProperty(pvObject, "Caption")
End Function ' getCaption
Access2BaseDev PropertiesGet getClickCount Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getClickCount(Optional pvObject As Variant) As Long
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getClickCount")
getClickCount = PropertiesGet._getProperty(pvObject, "ClickCount")
End Function ' getClickCount
Access2BaseDev PropertiesGet getContextShortcut Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getContextShortcut(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getContextShortcut")
getContextShortcut = PropertiesGet._getProperty(pvObject, "ContextShortcut")
End Function ' getContextShortcut
Access2BaseDev PropertiesGet getControlSource Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getControlSource(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlSource")
getControlSource = PropertiesGet._getProperty(pvObject, "ControlSource")
End Function ' getControlSource
Access2BaseDev PropertiesGet getControlTipText Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getControlTipText(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlTipText")
getControlTipText = PropertiesGet._getProperty(pvObject, "ControlTipText")
End Function ' getControlTipText
Access2BaseDev PropertiesGet getControlType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getControlType(Optional pvObject As Variant) As Integer
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getControlType")
getControlType = PropertiesGet._getProperty(pvObject, "ControlType")
End Function ' getControlType
Access2BaseDev PropertiesGet getCount Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getCount(Optional pvObject As Variant) As Integer
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCount")
getCount = PropertiesGet._getProperty(pvObject, "Count")
End Function ' getCount
Access2BaseDev PropertiesGet getCurrentRecord Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getCurrentRecord(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getCurrentRecord")
getCurrentRecord = PropertiesGet._getProperty(pvObject, "CurrentRecord")
End Function ' getCurrentRecord
Access2BaseDev PropertiesGet getDataType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getDataType(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDataType")
getDataType = PropertiesGet._getProperty(pvObject, "DataType")
End Function ' getDataType
Access2BaseDev PropertiesGet getDbType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getDbType(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDbType")
getDbType = PropertiesGet._getProperty(pvObject, "DbType")
End Function ' getDbType
Access2BaseDev PropertiesGet getDefault Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getDefault(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDefault")
getDefault = PropertiesGet._getProperty(pvObject, "Default")
End Function ' getDefault
Access2BaseDev PropertiesGet getDefaultValue Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getDefaultValue(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDefaultValue")
getDefaultValue = PropertiesGet._getProperty(pvObject, "DefaultValue")
End Function ' getDefaultValue
Access2BaseDev PropertiesGet getDescription Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getDescription(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getDescription")
getDescription = PropertiesGet._getProperty(pvObject, "Description")
End Function ' getDescription
Access2BaseDev PropertiesGet getEditMode Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getEditMode(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEditMode")
getEditMode = PropertiesGet._getProperty(pvObject, "EditMode")
End Function ' getEditMode
Access2BaseDev PropertiesGet getEnabled Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getEnabled(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEnabled")
getEnabled = PropertiesGet._getProperty(pvObject, "Enabled")
End Function ' getEnabled
Access2BaseDev PropertiesGet getEOF Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getEOF(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEOF")
getEOF = PropertiesGet._getProperty(pvObject, "EOF")
End Function ' getEOF
Access2BaseDev PropertiesGet getEventName Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getEventName(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEventName")
getEventName = PropertiesGet._getProperty(pvObject, "EventName")
End Function ' getEventName
Access2BaseDev PropertiesGet getEventType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getEventType(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getEventType")
getEventType = PropertiesGet._getProperty(pvObject, "EventType")
End Function ' getEventType
Access2BaseDev PropertiesGet getFieldSize Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFieldSize(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFieldSize")
getFieldSize = PropertiesGet._getProperty(pvObject, "FieldSize")
End Function ' getFieldSize
Access2BaseDev PropertiesGet getFilter Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFilter(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFilter")
getFilter = PropertiesGet._getProperty(pvObject, "Filter")
End Function ' getFilter
Access2BaseDev PropertiesGet getFilterOn Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFilterOn(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFilterOn")
getFilterOn = PropertiesGet._getProperty(pvObject, "FilterOn")
End Function ' getFilterOn
Access2BaseDev PropertiesGet getFocusChangeTemporary Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFocusChangeTemporary(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFocusChangeTemporary")
getFocusChangeTemporary = PropertiesGet._getProperty(pvObject, "FocusChangeTemporary")
End Function ' getFocusChangeTemporary
Access2BaseDev PropertiesGet getFontBold Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFontBold(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontBold")
getFontBold = PropertiesGet._getProperty(pvObject, "FontBold")
End Function ' getFontBold
Access2BaseDev PropertiesGet getFontItalic Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFontItalic(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontItalic")
getFontItalic = PropertiesGet._getProperty(pvObject, "FontItalic")
End Function ' getFontItalic
Access2BaseDev PropertiesGet getFontName Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFontName(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontName")
getFontName = PropertiesGet._getProperty(pvObject, "FontName")
End Function ' getFontName
Access2BaseDev PropertiesGet getFontSize Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFontSize(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontSize")
getFontSize = PropertiesGet._getProperty(pvObject, "FontSize")
End Function ' getFontSize
Access2BaseDev PropertiesGet getFontUnderline Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFontUnderline(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontUnderline")
getFontUnderline = PropertiesGet._getProperty(pvObject, "FontUnderline")
End Function ' getFontUnderline
Access2BaseDev PropertiesGet getFontWeight Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFontWeight(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFontWeight")
getFontWeight = PropertiesGet._getProperty(pvObject, "FontWeight")
End Function ' getFontWeight
Access2BaseDev PropertiesGet getForeColor Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getForeColor(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getForeColor")
getForeColor = PropertiesGet._getProperty(pvObject, "ForeColor")
End Function ' getForeColor
Access2BaseDev PropertiesGet getForm Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getForm(Optional pvObject As Variant) As Variant ' Return Subform pseudo
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getForm")
getForm = PropertiesGet._getProperty(pvObject, "Form")
End Function ' getForm
Access2BaseDev PropertiesGet getFormat Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getFormat(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getFormat")
getFormat = PropertiesGet._getProperty(pvObject, "Format")
End Function ' getFormat
Access2BaseDev PropertiesGet getHeight Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getHeight(Optional pvObject As Variant) As Long
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getHeight")
getHeight = PropertiesGet._getProperty(pvObject, "Height")
End Function ' getHeight
Access2BaseDev PropertiesGet getIsLoaded Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getIsLoaded(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getIsLoaded")
getIsLoaded = PropertiesGet._getProperty(pvObject, "IsLoaded")
End Function ' getIsLoaded
Access2BaseDev PropertiesGet getItemData Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getItemData(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getItemData")
If IsMissing(pvIndex) Then
getItemData = PropertiesGet._getProperty(pvObject, "ItemData")
Else
getItemData = PropertiesGet._getProperty(pvObject, "ItemData", pvIndex)
End If
End Function ' getItemData
Access2BaseDev PropertiesGet getKeyAlt Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getKeyAlt(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyAlt")
getKeyAlt = PropertiesGet._getProperty(pvObject, "KeyAlt")
End Function ' getKeyAlt
Access2BaseDev PropertiesGet getKeyChar Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getKeyChar(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyChar")
getKeyChar = PropertiesGet._getProperty(pvObject, "KeyChar")
End Function ' getKeyChar
Access2BaseDev PropertiesGet getKeyCode Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getKeyCode(Optional pvObject As Variant) As Integer
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyCode")
getKeyCode = PropertiesGet._getProperty(pvObject, "KeyCode")
End Function ' getKeyCode
Access2BaseDev PropertiesGet getKeyCtrl Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getKeyCtrl(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyCtrl")
getKeyCtrl = PropertiesGet._getProperty(pvObject, "KeyCtrl")
End Function ' getKeyCtrl
Access2BaseDev PropertiesGet getKeyFunction Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getKeyFunction(Optional pvObject As Variant) As Integer
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyFunction")
getKeyFunction = PropertiesGet._getProperty(pvObject, "KeyFunction")
End Function ' getKeyFunction
Access2BaseDev PropertiesGet getKeyShift Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getKeyShift(pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getKeyShift")
getKeyShift = PropertiesGet._getProperty(pvObject, "KeyShift")
End Function ' getKeyShift
Access2BaseDev PropertiesGet getLinkChildFields Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getLinkChildFields(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLinkChildFields")
If IsMissing(pvObject) Then
getLinkChildFields = PropertiesGet._getProperty(pvObject, "LinkChildFields")
Else
getLinkChildFields = PropertiesGet._getProperty(pvObject, "LinkChildFields", pvIndex)
End If
End Function ' getLinkChildFields
Access2BaseDev PropertiesGet getLinkMasterFields Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getLinkMasterFields(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLinkMasterFields")
If IsMissing(pvIndex) Then
getLinkMasterFields = PropertiesGet._getProperty(pvObject, "LinkMasterFields")
Else
getLinkMasterFields = PropertiesGet._getProperty(pvObject, "LinkMasterFields", pvIndex)
End If
End Function ' getLinkMasterFields
Access2BaseDev PropertiesGet getListCount Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getListCount(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getListCount")
getListCount = PropertiesGet._getProperty(pvObject, "ListCount")
End Function ' getListCount
Access2BaseDev PropertiesGet getListIndex Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getListIndex(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getListIndex")
getListIndex = PropertiesGet._getProperty(pvObject, "ListIndex")
End Function ' getListIndex
Access2BaseDev PropertiesGet getLocked Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getLocked(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getLocked")
getLocked = PropertiesGet._getProperty(pvObject, "Locked")
End Function ' getLocked
Access2BaseDev PropertiesGet getMultiSelect Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getMultiSelect(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getMultiSelect")
getMultiSelect = PropertiesGet._getProperty(pvObject, "MultiSelect")
End Function ' getMultiSelect
Access2BaseDev PropertiesGet getName Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getName(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getName")
getName = PropertiesGet._getProperty(pvObject, "Name")
End Function ' getName
Access2BaseDev PropertiesGet getObject Basic FindNext (Procedure)
FindRecord (Procedure)
GoToRecord (Procedure)
setValue (Procedure)
Item (Procedure)
getValue (Procedure)
_ParentObject (Procedure)
_PropertyGet (Procedure)
setFocus (Procedure)
79
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getObject(Optional pvShortcut As Variant) As Variant
' Return the object described by pvShortcut ignoring its final property
' Example: "Forms!myForm!myControl.myProperty" => Controls(Forms("myForm"), "myControl"))

Const cstEXCLAMATION = "!"
Const cstDOT = "."

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "getObject"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvShortcut) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvShortcut, 1, vbString) Then Goto Exit_Function

Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
Dim sComponents() As String, sSubComponents() As String, sDialog As String
Dim oDoc As Object
Set vCurrentObject = Nothing
sComponents = Split(Trim(pvShortcut), cstEXCLAMATION)
If UBound(sComponents) = 0 Then Goto Trace_Error
If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS", "TEMPVARS")) Then Goto Trace_Error
If sComponents(1) = "0" Or Left(sComponents(1), 2) = "0." Then
Set oDoc = _A2B_.CurrentDocument()
If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error
End If

sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT)
sComponents(UBound(sComponents)) = sSubComponents(0) ' Ignore final property, if any

Set vCurrentObject = New Collect
Select Case UCase(sComponents(0))
Case "FORMS" : vCurrentObject._CollType = COLLFORMS
Case "DIALOGS" : vCurrentObject._CollType = COLLALLDIALOGS
Case "TEMPVARS" : vCurrentObject._CollType = COLLTEMPVARS
End Select
For iCurrentIndex = 1 To UBound(sComponents) ' Start parsing ...
sSubComponents = Split(sComponents(iCurrentIndex), cstDOT)
sComponents(iCurrentIndex) = Utils._Trim(sSubComponents(0))
Select Case UBound(sSubComponents)
Case 0
sCurrentProperty = ""
Case 1
sCurrentProperty = sSubComponents(1)
Case Else
Goto Trace_Error
End Select
Select Case vCurrentObject._Type
Case OBJCOLLECTION
Select Case vCurrentObject._CollType
Case COLLFORMS
vCurrentObject = Application.Forms(sComponents(iCurrentIndex))
Case COLLALLDIALOGS
sDialog = UCase(sComponents(iCurrentIndex))
vCurrentObject = Application.AllDialogs(sDialog)
If Not vCurrentObject.IsLoaded Then Goto Trace_Error
Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog)
Case COLLTEMPVARS
If UBound(sComponents) > 1 Then Goto Trace_Error
vCurrentObject = Application.TempVars(sComponents(1))
'Case Else
End Select
Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG
vCurrentObject = vCurrentObject.Controls(sComponents(iCurrentIndex))
End Select
If sCurrentProperty <> "" Then vCurrentObject = vCurrentObject.getProperty(sCurrentProperty)
Next iCurrentIndex

Set getObject = vCurrentObject

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvShortcut))
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' getObject V0.9.5
Access2BaseDev PropertiesGet getObjectType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getObjectType(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getObjectType")
getObjectType = PropertiesGet._getProperty(pvObject, "ObjectType")
End Function ' getObjectType
Access2BaseDev PropertiesGet getOpenArgs Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getOpenArgs(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOpenArgs")
getOpenArgs = PropertiesGet._getProperty(pvObject, "OpenArgs")
End Function ' getOpenArgs
Access2BaseDev PropertiesGet getOptionGroup Basic   20
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getOptionGroup(Optional pvObject As Variant, pvName As variant) As Variant
' Return an OptionGroup object based on its name

Utils._SetCalledSub("getOptionGroup")
If IsMissing(pvObject) Or IsMissing(pvName) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function

If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
If Not Utils._CheckArgument(pvName, 2, vbString) Then Goto Exit_Function

getOptionGroup = pvObject.OptionGroup(pvName)

Exit_Function:
Utils._ResetCalledSub("getOptionGroup")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "getOptionGroup", Erl)
GoTo Exit_Function
End Function ' getOptionGroup V0.9.0
Access2BaseDev PropertiesGet getOptionValue Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getOptionValue(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOptionValue")
getOptionValue = PropertiesGet._getProperty(pvObject, "OptionValue")
End Function ' getOptionValue
Access2BaseDev PropertiesGet getOrderBy Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getOrderBy(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOrderBy")
getOrderBy = PropertiesGet._getProperty(pvObject, "OrderBy")
End Function ' getOrderBy
Access2BaseDev PropertiesGet getOrderByOn Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getOrderByOn(Optional pvObject As Variant) As Boolean
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getOrderByOn")
getOrderByOn = PropertiesGet._getProperty(pvObject, "OrderByOn")
End Function ' getOrderByOn
Access2BaseDev PropertiesGet getPage Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getPage(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getPage")
getPage = PropertiesGet._getProperty(pvObject, "Page")
End Function ' getPage V0.9.1
Access2BaseDev PropertiesGet getParent Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getParent(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getParent")
getParent = PropertiesGet._getProperty(pvObject, "Parent")
End Function ' getParent V0.9.0
Access2BaseDev PropertiesGet getProperty Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional pvItem As Variant, Optional ByVal pvProperty As Variant, ByVal Optional pvIndex As Variant) As Variant
' Return property value of object pvItem, and psProperty property name
Utils._SetCalledSub("getProperty")
If IsMissing(pvItem) Then Call _TraceArguments()
If IsMissing(pvProperty) Then Call _TraceArguments()
If IsMissing(pvIndex) Then getProperty = PropertiesGet._getProperty(pvItem, pvProperty) Else getProperty = PropertiesGet._getProperty(pvItem, pvProperty, pvIndex)
Utils._ResetCalledSub("getProperty")
End Function ' getProperty
Access2BaseDev PropertiesGet getRecommendation Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRecommendation(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecommendation")
getRecommendation = PropertiesGet._getProperty(pvObject, "Recommendation")
End Function ' getRecommendation
Access2BaseDev PropertiesGet getRecordCount Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRecordCount(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordCount")
getRecordCount = PropertiesGet._getProperty(pvObject, "RecordCount")
End Function ' getRecordCount
Access2BaseDev PropertiesGet getRecordset Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRecordset(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordset")
getRecordset = PropertiesGet._getProperty(pvObject, "Recordset")
End Function ' getRecordset V0.9.5
Access2BaseDev PropertiesGet getRecordSource Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRecordSource(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRecordSource")
getRecordSource = PropertiesGet._getProperty(pvObject, "RecordSource")
End Function ' getRecordSource
Access2BaseDev PropertiesGet getRequired Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRequired(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRequired")
getRequired = PropertiesGet._getProperty(pvObject, "Required")
End Function ' getRequired
Access2BaseDev PropertiesGet getRowChangeAction Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRowChangeAction(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowChangeAction")
getRowChangeAction = PropertiesGet._getProperty(pvObject, "RowChangeAction")
End Function ' getRowChangeAction
Access2BaseDev PropertiesGet getRowSource Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRowSource(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowSource")
getRowSource = PropertiesGet._getProperty(pvObject, "RowSource")
End Function ' getRowSource
Access2BaseDev PropertiesGet getRowSourceType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getRowSourceType(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getRowSourceType")
getRowSourceType = PropertiesGet._getProperty(pvObject, "RowSourceType")
End Function ' getRowSourceType
Access2BaseDev PropertiesGet getSelected Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSelected(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSelected")
If IsMissing(pvIndex) Then
getSelected = PropertiesGet._getProperty(pvObject, "Selected")
Else
getSelected = PropertiesGet._getProperty(pvObject, "Selected", pvIndex)
End If
End Function ' getSelected
Access2BaseDev PropertiesGet getSize Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSize(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSize")
getSize = PropertiesGet._getProperty(pvObject, "Size")
End Function ' getSize
Access2BaseDev PropertiesGet getSource Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSource(Optional pvObject As Variant) As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSource")
getSource = PropertiesGet._getProperty(pvObject, "Source")
End Function ' getSource V0.9.0
Access2BaseDev PropertiesGet getSourceField Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSourceField(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSourceField")
getSourceField = PropertiesGet._getProperty(pvObject, "SourceField")
End Function ' getSourceField
Access2BaseDev PropertiesGet getSourceTable Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSourceTable(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSourceTable")
getSourceTable = PropertiesGet._getProperty(pvObject, "SourceTable")
End Function ' getSourceTable
Access2BaseDev PropertiesGet getSpecialEffect Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSpecialEffect(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSpecialEffect")
getSpecialEffect = PropertiesGet._getProperty(pvObject, "SpecialEffect")
End Function ' getSpecialEffect
Access2BaseDev PropertiesGet getSubComponentName Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSubComponentName(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubComponentName")
getSubComponentName = PropertiesGet._getProperty(pvObject, "SubComponentName")
End Function ' getSubComponentName
Access2BaseDev PropertiesGet getSubComponentType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSubComponentType(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubComponentType")
getSubComponentType = PropertiesGet._getProperty(pvObject, "SubComponentType")
End Function ' getSubComponentType
Access2BaseDev PropertiesGet getSubType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getSubType(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getSubType")
getSubType = PropertiesGet._getProperty(pvObject, "SubType")
End Function ' getSubType
Access2BaseDev PropertiesGet getTabIndex Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTabIndex(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTabIndex")
getTabIndex = PropertiesGet._getProperty(pvObject, "TabIndex")
End Function ' getTabIndex
Access2BaseDev PropertiesGet getTabStop Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTabStop(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTabStop")
getTabStop = PropertiesGet._getProperty(pvObject, "TabStop")
End Function ' getTabStop
Access2BaseDev PropertiesGet getTag Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTag(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTag")
getTag = PropertiesGet._getProperty(pvObject, "Tag")
End Function ' getTag
Access2BaseDev PropertiesGet getText Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getText(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getText")
getText = PropertiesGet._getProperty(pvObject, "Text")
End Function ' getText
Access2BaseDev PropertiesGet getTextAlign Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTextAlign(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTextAlign")
getTextAlign = PropertiesGet._getProperty(pvObject, "TextAlign")
End Function ' getTextAlign
Access2BaseDev PropertiesGet getTooltipText Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTooltipText(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTooltipText")
getTooltipText = PropertiesGet._getProperty(pvObject, "TooltipText")
End Function ' getTooltipText
Access2BaseDev PropertiesGet getTripleState Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTripleState(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTripleState")
getTripleState = PropertiesGet._getProperty(pvObject, "TripleState")
End Function ' getTripleState
Access2BaseDev PropertiesGet getTypeName Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getTypeName(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getTypeName")
getTypeName = PropertiesGet._getProperty(pvObject, "TypeName")
End Function ' getTypeName
Access2BaseDev PropertiesGet getValue Basic Item (Procedure)
_ParentObject (Procedure)
17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getValue(Optional pvObject As Variant) As Variant
' getValue also interprets shortcut strings !!
Dim vItem As Variant, sProperty As String
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getValue")
If VarType(pvObject) = vbString Then
Utils._SetCalledSub("getValue")
Set vItem = getObject(pvObject)
sProperty = Utils._FinalProperty(pvObject)
If sProperty = "" Then sProperty = "Value" ' Default value if final property in shortcut is absent
getValue = vItem.getProperty(sproperty)
Utils._ResetCalledSub("getValue")
Else
Set vItem = pvObject
getValue = vItem.getProperty("Value")
End If
End Function ' getValue
Access2BaseDev PropertiesGet getVisible Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getVisible(Optional pvObject As Variant) As Variant
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getVisible")
getVisible = PropertiesGet._getProperty(pvObject, "Visible")
End Function ' getVisible
Access2BaseDev PropertiesGet getWidth Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getWidth(Optional pvObject As Variant) As Long
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getWdth")
getWidth = PropertiesGet._getProperty(pvObject, "Width")
End Function ' getWidth
Access2BaseDev PropertiesGet getXPos Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getXPos(Optional pvObject As Variant) As Long
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getXPos")
getXPos = PropertiesGet._getProperty(pvObject, "XPos")
End Function ' getXPos
Access2BaseDev PropertiesGet getYPos Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getYPos(Optional pvObject As Variant) As Long
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments("getYPos")
getYPos = PropertiesGet._getProperty(pvObject, "YPos")
End Function ' getYPos
Access2BaseDev PropertiesSet _CheckProperty Basic   18
Private Function _CheckProperty(pvObject As Object, ByVal psProperty As String) As Boolean
' Return False if psProperty not within the PropertyValues set of pvItem

Dim i As Integer, oPropertyValues As Variant, oProperty As Variant
oPropertyValues = pvObject.PropertyValues

For i = LBound(oPropertyValues) To UBound(oPropertyValues)
oProperty = oPropertyValues(i)
If UCase(oProperty.Name) = UCase(psProperty) Then
_CheckProperty = True
Exit Function
End If
Next i

_CheckProperty = False
Exit Function

End Function ' CheckProperty V0.7.5
Access2BaseDev PropertiesSet _setProperty Basic setAbsolutePosition (Procedure)
setAllowAdditions (Procedure)
setAllowDeletions (Procedure)
setAllowEdits (Procedure)
setBackColor (Procedure)
setBookmark (Procedure)
setBorderColor (Procedure)
setBorderStyle (Procedure)
setCancel (Procedure)
setCaption (Procedure)
setControlTipText (Procedure)
setCurrentRecord (Procedure)
setDefault (Procedure)
setDefaultValue (Procedure)
setDescription (Procedure)
setEnabled (Procedure)
setFilter (Procedure)
setFilterOn (Procedure)
setFontBold (Procedure)
setFontItalic (Procedure)
setFontName (Procedure)
setFontSize (Procedure)
setFontUnderline (Procedure)
setFontWeight (Procedure)
setForeColor (Procedure)
setHeight (Procedure)
setListIndex (Procedure)
setLocked (Procedure)
setMultiSelect (Procedure)
setOnAction (Procedure)
setOptionValue (Procedure)
setOrderBy (Procedure)
setOrderByOn (Procedure)
setPage (Procedure)
setProperty (Procedure)
setRecordSource (Procedure)
setRequired (Procedure)
setRowSource (Procedure)
setRowSourceType (Procedure)
setSelected (Procedure)
setSelLength (Procedure)
setSelStart (Procedure)
setSelText (Procedure)
setSpecialEffect (Procedure)
setTabIndex (Procedure)
setTabStop (Procedure)
setTag (Procedure)
setTextAlign (Procedure)
setTooltipText (Procedure)
setTripleState (Procedure)
setVisible (Procedure)
setWidth (Procedure)
208
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _setProperty(pvItem As Variant, ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean
' Return True if property setting OK
Utils._SetCalledSub("set" & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function

'pvItem must be an object and have the requested property
If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function
'Check Index argument
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 4, Utils._AddNumeric()) Then Goto Exit_Function
End If
'Execute
Dim iArgNr As Integer, lFormat As Long
Dim i As Integer, iCount As Integer, iSelectedItems() As Integer, bListboxBound As Boolean
Dim odbDatabase As Object, vNames As Variant, bFound As Boolean, sName As String, oModel As Object
Dim ocButton As Variant, iRadioIndex As Integer
_setProperty = True
If _A2B_.CalledSub = "setProperty" Then iArgNr = 3 Else iArgNr = 2
If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error_Control
Select Case UCase(psProperty)
Case UCase("AbsolutePosition")
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
pvItem.AbsolutePosition = pvValue
Case UCase("AllowAdditions")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.AllowAdditions = pvValue
Case UCase("AllowDeletions")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.AllowDeletions = pvValue
Case UCase("AllowEdits")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.AllowEdits = pvValue
Case UCase("BackColor")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.BackColor = pvValue
Case UCase("Bookmark")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function
pvItem.Bookmark = pvValue
Case UCase("BorderColor")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.BorderColor = pvValue
Case UCase("BorderStyle")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.BorderColor = pvValue
Case UCase("Cancel")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.Cancel = pvValue
Case UCase("Caption")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function
pvItem.Caption = pvValue
Case UCase("ControlTipText")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.ControlTipText = pvValue
Case UCase("CurrentRecord")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.CurrentRecord = pvValue
Case UCase("Default")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.Default = pvValue
Case UCase("DefaultValue")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function
pvItem.DefaultValue = pvValue
Case UCase("Description")
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
pvItem.DefaultValue = pvValue
Case UCase("Enabled")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.Enabled = pvValue
Case UCase("Filter")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function
pvItem.Filter = pvValue
Case UCase("FilterOn")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.FilterOn = pvValue
Case UCase("FontBold")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.FontBold = pvValue
Case UCase("FontItalic")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.FontItalic = pvValue
Case UCase("FontName")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.FontName = pvValue
Case UCase("FontSize")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.FontSize = pvValue
Case UCase("FontUnderline")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.FontUnderline = pvValue
Case UCase("FontWeight")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.FontWeight = pvValue
Case UCase("ForeColor")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.ForeColor = pvValue
Case UCase("Height")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
pvItem.Height = pvValue
Case UCase("ListIndex")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.ListIndex = pvValue
Case UCase("Locked")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.Locked = pvValue
Case UCase("MultiSelect")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.MultiSelect = pvValue
Case UCase("OnAction")
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
pvItem.OnAction = pvValue
Case UCase("OptionValue")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.OptionValue = pvValue
Case UCase("OrderBy")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.OrderBy = pvValue
Case UCase("OrderByOn")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.OrderByOn = pvValue
Case UCase("Page")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function
pvItem.Page = pvValue
Case UCase("RecordSource")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
pvItem.RecordSource = pvValue
Case UCase("Required")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.Required = pvValue
Case UCase("RowSource")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.RowSource = pvValue
Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.RowSourceType = pvValue
Case UCase("Selected")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
If IsMissing(pvIndex) Then pvItem.Selected = pvValue Else pvItem.SelectedI(pvValue, pvIndex)
Case UCase("SelLength")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.SelLength = pvValue
Case UCase("SelStart")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.SelStart = pvValue
Case UCase("SelText")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.SelText = pvValue
Case UCase("SpecialEffect")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.SpecialEffect = pvValue
Case UCase("TabIndex")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.TabIndex = pvValue
Case UCase("TabStop")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.TabStop = pvValue
Case UCase("Tag")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.Tag = pvValue
Case UCase("TextAlign")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.TextAlign = pvValue
Case UCase("TooltipText")
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
pvItem.TooltipText = pvValue
Case UCase("TripleState")
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
pvItem.TripleState = pvValue
Case UCase("Value")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function
pvItem.Value = pvValue
Case UCase("Visible")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function
pvItem.Visible = pvValue
Case UCase("Width")
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
pvItem.Width = pvValue
Case Else
Goto Trace_Error_Control
End Select

Exit_Function:
Utils._ResetCalledSub("set" & psProperty)
Exit Function
Trace_Error_Form:
TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, 1, pvItem._Name)
_setProperty = False
Goto Exit_Function
Trace_Error_Control:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_setProperty = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_setProperty = False
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
_setProperty = Nothing
Goto Exit_Function
Trace_Error_Array:
TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr)
_setProperty = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "_setProperty", Erl)
GoTo Exit_Function
End Function ' _setProperty V0.9.1
Access2BaseDev PropertiesSet setAbsolutePosition Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setAbsolutePosition(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAbsolutePosition")
setAbsolutePosition = PropertiesSet._setProperty(pvObject, "AbsolutePosition", pvValue)
End Function ' setAbsolutePosition
Access2BaseDev PropertiesSet setAllowAdditions Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setAllowAdditions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowAdditions")
setAllowAdditions = PropertiesSet._setProperty(pvObject, "AllowAdditions", pvValue)
End Function ' setAllowAdditions
Access2BaseDev PropertiesSet setAllowDeletions Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setAllowDeletions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowDeletions")
setAllowDeletions = PropertiesSet._setProperty(pvObject, "AllowDeletions", pvValue)
End Function ' setAllowDeletions
Access2BaseDev PropertiesSet setAllowEdits Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setAllowEdits(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowEdits")
setAllowEdits = PropertiesSet._setProperty(pvObject, "AllowEdits", pvValue)
End Function ' setAllowEdits
Access2BaseDev PropertiesSet setBackColor Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setBackColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBackColor")
setBackColor = PropertiesSet._setProperty(pvObject, "BackColor", pvValue)
End Function ' setBackColor
Access2BaseDev PropertiesSet setBookmark Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setBookmark(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBookmark")
setBookmark = PropertiesSet._setProperty(pvObject, "Bookmark", pvValue)
End Function ' setBookmark
Access2BaseDev PropertiesSet setBorderColor Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setBorderColor (Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderColor")
setBorderColor = PropertiesSet._setProperty(pvObject, "BorderColor", pvValue)
End Function ' setBorderColor
Access2BaseDev PropertiesSet setBorderStyle Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setBorderStyle(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderStyle")
setBorderStyle = PropertiesSet._setProperty(pvObject, "BorderStyle", pvValue)
End Function ' setBorderStyle
Access2BaseDev PropertiesSet setCancel Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setCancel(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCancel")
setCancel = PropertiesSet._setProperty(pvObject, "Cancel", pvValue)
End Function ' setCancel
Access2BaseDev PropertiesSet setCaption Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setCaption(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCaption")
setCaption = PropertiesSet._setProperty(pvObject, "Caption", pvValue)
End Function ' setCaption
Access2BaseDev PropertiesSet setControlTipText Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setControlTipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setControlTipText")
setControlTipText = PropertiesSet._setProperty(pvObject, "ControlTipText", pvValue)
End Function ' setControlTipText
Access2BaseDev PropertiesSet setCurrentRecord Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setCurrentRecord(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCurrentRecord")
setCurrentRecord = PropertiesSet._setProperty(pvObject, "CurrentRecord", pvValue)
End Function ' setCurrentRecord
Access2BaseDev PropertiesSet setDefault Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setDefault(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefault")
setDefault = PropertiesSet._setProperty(pvObject, "Default", pvValue)
End Function ' setDefault
Access2BaseDev PropertiesSet setDefaultValue Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setDefaultValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefaultValue")
setDefaultValue = PropertiesSet._setProperty(pvObject, "DefaultValue", pvValue)
End Function ' setDefaultValue
Access2BaseDev PropertiesSet setDescription Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setDescription(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDescription")
setDescription = PropertiesSet._setProperty(pvObject, "Description", pvValue)
End Function ' setDescription
Access2BaseDev PropertiesSet setEnabled Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setEnabled(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setEnabled")
setEnabled = PropertiesSet._setProperty(pvObject, "Enabled", pvValue)
End Function ' setEnabled
Access2BaseDev PropertiesSet setFilter Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFilter(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilter")
setFilter = PropertiesSet._setProperty(pvObject, "Filter", pvValue)
End Function ' setFilter
Access2BaseDev PropertiesSet setFilterOn Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFilterOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilterOn")
setFilterOn = PropertiesSet._setProperty(pvObject, "FilterOn", pvValue)
End Function ' setFilterOn
Access2BaseDev PropertiesSet setFontBold Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFontBold(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontBold")
setFontBold = PropertiesSet._setProperty(pvObject, "FontBold", pvValue)
End Function ' setFontBold
Access2BaseDev PropertiesSet setFontItalic Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFontItalic(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontItalic")
setFontItalic = PropertiesSet._setProperty(pvObject, "FontItalic", pvValue)
End Function ' setFontItalic
Access2BaseDev PropertiesSet setFontName Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFontName(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontName")
setFontName = PropertiesSet._setProperty(pvObject, "FontName", pvValue)
End Function ' setFontName
Access2BaseDev PropertiesSet setFontSize Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFontSize(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontSize")
setFontSize = PropertiesSet._setProperty(pvObject, "FontSize", pvValue)
End Function ' setFontSize
Access2BaseDev PropertiesSet setFontUnderline Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFontUnderline(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontUnderline")
setFontUnderline = PropertiesSet._setProperty(pvObject, "FontUnderline", pvValue)
End Function ' setFontUnderline
Access2BaseDev PropertiesSet setFontWeight Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setFontWeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontWeight")
setFontWeight = PropertiesSet._setProperty(pvObject, "FontWeight", pvValue)
End Function ' setFontWeight
Access2BaseDev PropertiesSet setForeColor Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setForeColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setForeColor")
setForeColor = PropertiesSet._setProperty(pvObject, "ForeColor", pvValue)
End Function ' setForeColor
Access2BaseDev PropertiesSet setHeight Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setHeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setHeight")
setHeight = PropertiesSet._setProperty(pvObject, "Height", pvValue)
End Function ' setHeight
Access2BaseDev PropertiesSet setListIndex Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setListIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setListIndex")
setListIndex = PropertiesSet._setProperty(pvObject, "ListIndex", pvValue)
End Function ' setListIndex
Access2BaseDev PropertiesSet setLocked Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setLocked(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setLocked")
setLocked = PropertiesSet._setProperty(pvObject, "Locked", pvValue)
End Function ' setLocked
Access2BaseDev PropertiesSet setMultiSelect Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setMultiSelect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setMultiSelect")
setMultiSelect = PropertiesSet._setProperty(pvObject, "MultiSelect", pvValue)
End Function ' setMultiSelect
Access2BaseDev PropertiesSet setOnAction Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setOnAction(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOnAction")
setOnAction = PropertiesSet._setProperty(pvObject, "OnAction", pvValue)
End Function ' setOnAction
Access2BaseDev PropertiesSet setOptionValue Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setOptionValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOptionValue")
setOptionValue = PropertiesSet._setProperty(pvObject, "OptionValue", pvValue)
End Function ' setOptionValue
Access2BaseDev PropertiesSet setOrderBy Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setOrderBy(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderBy")
setOrderBy = PropertiesSet._setProperty(pvObject, "OrderBy", pvValue)
End Function ' setOrderBy
Access2BaseDev PropertiesSet setOrderByOn Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setOrderByOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderByOn")
setOrderByOn = PropertiesSet._setProperty(pvObject, "OrderByOn", pvValue)
End Function ' setOrderByOn
Access2BaseDev PropertiesSet setPage Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setPage(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setPage")
setPage = PropertiesSet._setProperty(pvObject, "Page", pvValue)
End Function ' setPage V0.9.1
Access2BaseDev PropertiesSet setProperty Basic   12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(Optional pvItem As Variant, ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Variant
' Return True if property setting OK
Utils._SetCalledSub("setProperty")
If IsMissing(pvItem) Or IsMissing(psProperty) Or IsMissing(pvValue) Or IsEmpty(pvItem) Then Call _TraceArguments()
If IsMissing(pvIndex) Then
setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue)
Else
setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue, pvIndex)
End If
Utils._ResetCalledSub("setProperty")
End Function
Access2BaseDev PropertiesSet setRecordSource Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setRecordSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRecordSource")
setRecordSource = PropertiesSet._setProperty(pvObject, "RecordSource", pvValue)
End Function ' setRecordSource
Access2BaseDev PropertiesSet setRequired Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setRequired(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRequired")
setRequired = PropertiesSet._setProperty(pvObject, "Required", pvValue)
End Function ' setRequired
Access2BaseDev PropertiesSet setRowSource Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setRowSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSource")
setRowSource = PropertiesSet._setProperty(pvObject, "RowSource", pvValue)
End Function ' setRowSource
Access2BaseDev PropertiesSet setRowSourceType Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setRowSourceType(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSourceType")
setRowSourceType = PropertiesSet._setProperty(pvObject, "RowSourceType", pvValue)
End Function ' setRowSourceType
Access2BaseDev PropertiesSet setSelected Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setSelected(Optional pvObject As Variant, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Then Call _TraceArguments("setSelected")
If IsEmpty(pvObject) Then Call _TraceArguments("setSelected")
If IsMissing(pvIndex) Then
setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue)
Else
setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue, pvIndex)
End If
End Function ' setSelected
Access2BaseDev PropertiesSet setSelLength Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setSelLength(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelLength")
setSelLength = PropertiesSet._setProperty(pvObject, "SelLength", pvValue)
End Function ' setSelLength
Access2BaseDev PropertiesSet setSelStart Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setSelStart(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelStart")
setSelStart = PropertiesSet._setProperty(pvObject, "SelStart", pvValue)
End Function ' setSelStart
Access2BaseDev PropertiesSet setSelText Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setSelText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelText")
setSelText = PropertiesSet._setProperty(pvObject, "SelText", pvValue)
End Function ' setSelText
Access2BaseDev PropertiesSet setSpecialEffect Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setSpecialEffect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSpecialEffect")
setSpecialEffect = PropertiesSet._setProperty(pvObject, "SpecialEffect", pvValue)
End Function ' setSpecialEffect
Access2BaseDev PropertiesSet setTabIndex Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setTabIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabIndex")
setTabIndex = PropertiesSet._setProperty(pvObject, "TabIndex", pvValue)
End Function ' setTabIndex
Access2BaseDev PropertiesSet setTabStop Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setTabStop(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabStop")
setTabStop = PropertiesSet._setProperty(pvObject, "TabStop", pvValue)
End Function ' setTabStop
Access2BaseDev PropertiesSet setTag Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setTag(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTag")
setTag = PropertiesSet._setProperty(pvObject, "Tag", pvValue)
End Function ' setTag
Access2BaseDev PropertiesSet setTextAlign Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setTextAlign(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTextAlign")
setTextAlign = PropertiesSet._setProperty(pvObject, "TextAlign", pvValue)
End Function ' setTextAlign
Access2BaseDev PropertiesSet setTooltipText Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setTooltipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTooltipText")
setTooltipText = PropertiesSet._setProperty(pvObject, "TooltipText", pvValue)
End Function ' setTooltipText
Access2BaseDev PropertiesSet setTripleState Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setTripleState(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTripleState")
setTripleState = PropertiesSet._setProperty(pvObject, "TripleState", pvValue)
End Function ' setTripleState
Access2BaseDev PropertiesSet setValue Basic   17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' setValue also interprets shortcut strings !!
Dim vItem As Variant, sProperty As String
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setValue")
If VarType(pvObject) = vbString Then
Utils._SetCalledSub("setValue")
Set vItem = getObject(pvObject)
sProperty = Utils._FinalProperty(pvObject)
If sProperty = "" Then sProperty = "Value"
setValue = vItem.setProperty(sProperty, pvValue)
Utils._ResetCalledSub("setValue")
Else
Set vItem = pvObject
setValue = vItem.setProperty("Value", pvValue)
End If
End Function ' setValue
Access2BaseDev PropertiesSet setVisible Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setVisible(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms and controls
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setVisible")
setVisible = PropertiesSet._setProperty(pvObject, "Visible", pvValue)
End Function ' setVisible
Access2BaseDev PropertiesSet setWidth Basic   6
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setWidth(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
' Only for open forms
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setWidth")
setWidth = PropertiesSet._setProperty(pvObject, "Width", pvValue)
End Function ' setWidth
Access2BaseDev Property _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
6
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
_PropertiesList = Array("Name", "ObjectType", "Value")
End Function ' _PropertiesList
Access2BaseDev Property _PropertyGet Basic Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
Properties (Procedure)
Value (Procedure)
getProperty (Procedure)
31
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Property.get" & psProperty)
_PropertyGet = Nothing

Select Case UCase(psProperty)
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Value")
_PropertyGet = _Value
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("Property.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Property._PropertyGet", Erl)
_PropertyGet = Nothing
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Property Class_Initialize Basic Class_Terminate (Procedure) 8
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJPROPERTY
_Name = ""
_Value = Null
End Sub ' Constructor
Access2BaseDev Property Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Property Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Property getProperty Basic   9
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("Property.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Property.getProperty")

End Function ' getProperty
Access2BaseDev Property hasProperty Basic   8
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
Access2BaseDev Property Name Basic   3
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Property ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Property pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev Property Properties Basic   20
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, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev Property Value Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Value() As Variant
Value = _PropertyGet("Value")
End Property ' Value (get)
Access2BaseDev Recordset _AppendChunk Basic   48
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _AppendChunk(ByVal psFieldName As String, ByRef pvChunk As Variant, piChunkType) As Boolean
' Write chunk at the end of the file dedicated to the given field

If _ErrorHandler() Then On Local Error GoTo Error_Function
Dim oFileAccess As Object
Dim i As Integer, oChunk As Object, iChunk As Integer

' Do nothing if chunk meaningless
_AppendChunk = False
If IsNull(pvChunk) Then GoTo Exit_Function
If IsArray(pvChunk) Then
If UBound(pvChunk) < LBound(pvChunk) Then GoTo Exit_Function ' Empty array
End If

' Find or create relevant chunk entry
iChunk = -1
For i = 0 To UBound(_ManageChunks)
Set oChunk = _ManageChunks(i)
If oChunk.FieldName = psFieldName Then
iChunk = i
Exit For
End If
Next i
If iChunk = -1 Then
_AppendChunkInit(psFieldName)
iChunk = UBound(_ManageChunks)
End If

Set oChunk = _ManageChunks(iChunk)
With oChunk
If Not .ChunksRequested Then ' First chunk
.ChunksRequested = True
.ChunkType = piChunkType
.FileName = Utils._GetRandomFileName(_Name)
Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
.FileHandler = oFileAccess.openFileWrite(.FileName)
End If
.FileHandler.writeBytes(pvChunk)
End With
_AppendChunk = True

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Recordset._AppendChunk", Erl)
GoTo Exit_Function
End Function ' AppendChunk V1.5.0
Access2BaseDev Recordset _AppendChunkClose Basic CancelUpdate (Procedure)
Update (Procedure)
44
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _AppendChunkClose(ByVal pbCancel As Boolean) As Boolean
' Stores file content to database field(s)
' Called from Update() [pbCancel = False] or CancelUpdate() [pbCancel = True]

If _ErrorHandler() Then On Local Error GoTo Error_Function
Dim oFileAccess As Object, oStream As Object, lFileLength As Long, oField As Object
Dim i As Integer, oChunk As Object

_AppendChunkClose = False
For i = 0 To UBound(_ManageChunks)
Set oChunk = _ManageChunks(i)
With oChunk
If Not .ChunksRequested Then GoTo Exit_Function
If IsNull(.FileHandler) Then GoTo Exit_Function
.Filehandler.closeOutput
Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
' Copy file to field
If Not pbCancel Then
Set oStream = oFileAccess.openFileRead(.FileName)
lFileLength = oStream.getLength()
If lFileLength > 0 Then
Set oField = RowSet.getColumns.getByName(.FieldName)
Select Case .ChunkType
Case vbByte
oField.updateBinaryStream(oStream, lFileLength)
' Case vbString ' DOES NOT WORK FOR CHARACTER TYPES
' oField.updateCharacterStream(oStream, lFileLength)
End Select
End If
oStream.closeInput()
End If
If oFileAccess.exists(.FileName) Then oFileAccess.kill(.FileName)
End With
Next i
Set _ManageChunks = Array()
_AppendChunkClose = True

Exit_Function:
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "Recordset._AppendChunkClose", Erl)
GoTo Exit_Function
End Function ' AppendChunkClose V1.5.0
Access2BaseDev Recordset _AppendChunkInit Basic _AppendChunk (Procedure) 16
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _AppendChunkInit(psFieldName As String) As Boolean
' Initialize chunks manager

Dim iSize As Integer
iSize = UBound(_ManageChunks) + 1
ReDim Preserve _ManageChunks(0 To iSize)
Set _ManageChunks(iSize) = New ChunkDescriptor
With _ManageChunks(iSize)
.ChunksRequested = False
.FieldName = psFieldName
.FileName = ""
Set .FileHandler = Nothing
End With

End Function ' AppendChunkInit V1.5.0
Access2BaseDev Recordset _Initialize Basic   56
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize(ByVal Optional pvFilter As Variant, Optional poRowSet As Object)
' Initialize new recordset

If _Command = "" Then Exit Sub

If _ErrorHandler() Then On Local Error Goto Error_Sub
If IsMissing(pvFilter) Then pvFilter = ""
If Not IsMissing(poRowSet) Then ' Clone
Set RowSet = poRowSet.createResultSet()
_IsClone = True
RowSet.last() ' Solves bookmark desynchro when parent bookmark is used ?!?
Else
Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet")
_IsClone = False
With RowSet
If IsNull(.ActiveConnection) Then Set .ActiveConnection = _ParentDatabase.Connection
.CommandType = _CommandType
.Command = _Command
If _ForwardOnly Then .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY _
Else .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_SENSITIVE
If _PassThrough Then .EscapeProcessing = False _
Else .EscapeProcessing = True
If _ReadOnly Then
.ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
.TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_UNCOMMITTED ' Dirty read
Else
.ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.UPDATABLE
.TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_COMMITTED
End If
End With

If Not IsMissing(pvFilter) Then ' Filter must be set before execute()
If pvFilter <> "" Then
RowSet.Filter = pvFilter
RowSet.ApplyFilter = True
End If
End If
On Local Error Goto SQL_Error
RowSet.execute()
On Local Error Goto Error_Sub
End If
_DataSet = True
'If the Recordset contains no records, the BOF and EOF properties are True, and there is no current record.
_BOF = ( RowSet.IsRowCountFinal And RowSet.RowCount = 0 )
_EOF = _BOF

Exit_Sub:
Exit Sub
SQL_Error:
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , _Command)
Goto Exit_Sub
Error_Sub:
TraceError(TRACEABORT, Err, "Recordset._Initialize", Erl)
GoTo Exit_Sub
End Sub ' _Initialize
Access2BaseDev Recordset _Move Basic GetRows (Procedure)
Move (Procedure)
MoveFirst (Procedure)
MoveLast (Procedure)
MoveNext (Procedure)
MovePrevious (Procedure)
_PropertySet (Procedure)
107
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Move(pvTarget As Variant, ByVal Optional pvBookmark As Variant, ByVal Optional pbAbsolute As Boolean) As Boolean
'Move to the first, last, next, or previous record in a specified Recordset object and make that record the current record.

Dim cstThisSub As String
cstThisSub = "Recordset.Move" & Iif(VarType(pvTarget) = vbString, pvTarget, "")
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function

If IsNull(RowSet) Then Goto Trace_Closed
If Not _DataSet Then Goto Trace_NoData
If _BOF And _EOF Then Goto Trace_NoData
_Move = False
CancelUpdate() ' Any Move cancels all updates, even Move(0) !

Dim l As Long, lRow As Long
With RowSet
Select Case VarType(pvTarget)
Case vbString
Select Case UCase(pvTarget)
Case "FIRST"
If _ForwardOnly Then
If Not ( .isBeforeFirst() Or .isFirst() ) Then
Goto Trace_Forward
Else
.next()
End If
Else
.first()
End If
Case "LAST"
If _ForwardOnly Then
If .isAfterLast() Then Goto Trace_Forward
Do While Not ( .isRowCountFinal And .Row = .RowCount ) ' isLast() = True after reading of first records chunk
.next()
Loop
Else
.last()
End If
Case "NEXT"
If _EOF Then Goto Trace_OutOfRange
.next()
Case "PREVIOUS"
If _ForwardOnly Then Goto Trace_Forward
If _BOF Then Goto Trace_OutOfRange
.previous()
End Select
Case Else ' Relative or absolute move
If IsMissing(pbAbsolute) Then pbAbsolute = False ' Relative move is default
If _ForwardOnly And pvTarget < 0 then Goto Trace_Forward
If IsMissing(pvBookmark) Then
If pvTarget = 0 Then Goto Exit_Function ' Do nothing
If _ForwardOnly Then
If pbAbsolute Then lRow = .getRow() Else lRow = 0
For l = 1 To pvTarget - lRow
If .isAfterLast() Then Exit For
.next()
Next l
Else
If pbAbsolute Then .absolute(pvTarget) Else .relative(pvTarget)
End If
Else ' Move is always relative when bookmark argument present
If _ForwardOnly Then Goto Trace_Forward
If pvTarget = 0 Then
.moveToBookmark(pvBookmark)
Else
.moveRelativeToBookmark(pvBookmark, pvTarget)
End If
End If
End Select

_BOF = .isBeforeFirst() ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=76640
_EOF = .isAfterlast()
If _BOF Or _EOF Then
_Move = False
Else
If .rowDeleted() Then Goto Error_RowDeleted
If .rowUpdated() Then .refreshRow()
_Move = True
End If
End With

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Exit_Close: ' Force close of recordset when error raised
mClose()
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Close
Trace_Forward:
TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0)
Goto Exit_Close
Trace_NoData:
TraceError(TRACEFATAL, ERRRECORDSETNODATA, Utils._CalledSub(), 0)
Goto Exit_Close
Trace_OutOfRange:
TraceError(TRACEFATAL, ERRRECORDSETRANGE, Utils._CalledSub(), 0)
Goto Exit_Close
Error_RowDeleted:
TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0)
Goto Exit_Function
Trace_Closed:
TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0)
Goto Exit_Close
End Function ' Move
Access2BaseDev Recordset _PropertiesList Basic hasProperty (Procedure)
Properties (Procedure)
8
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

_PropertiesList = Array("AbsolutePosition", "BOF", "Bookmarkable", "Bookmark", "EditMode" _
, "EOF", "Filter", "LastModified", "Name", "ObjectType" , "RecordCount" _
)

End Function ' _PropertiesList
Access2BaseDev Recordset _PropertyGet Basic AbsolutePosition (Procedure)
BOF (Procedure)
Bookmark (Procedure)
Bookmarkable (Procedure)
EOF (Procedure)
EditMode (Procedure)
Filter (Procedure)
LastModified (Procedure)
Name (Procedure)
ObjectType (Procedure)
RecordCount (Procedure)
getProperty (Procedure)
Properties (Procedure)
89
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = "Recordset.get"
Utils._SetCalledSub(cstThisSub & psProperty)

_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("AbsolutePosition")
If IsNull(RowSet) Then Goto Trace_Closed
With RowSet
Select Case True
Case _BOF And _EOF : _PropertyGet = -1
Case .isBeforeFirst() Or .isAfterLast() : _PropertyGet = -1
Case Else : _PropertyGet = .getRow() ' Not getRow() - 1 as MSAccess requires
End Select
End With
Case UCase("BOF")
If IsNull(RowSet) Then Goto Trace_Closed
Select Case True
Case _BOF And _EOF : _PropertyGet = True
Case RowSet.isBeforeFirst() : _PropertyGet = True
Case Else : _PropertyGet = False
End Select
Case UCase("Bookmarkable")
If IsNull(RowSet) Then Goto Trace_Closed
If _ForwardOnly Then _PropertyGet = False Else _PropertyGet = RowSet.IsBookmarkable
Case UCase("Bookmark")
If IsNull(RowSet) Then Goto Trace_Closed
If RowSet.IsBookmarkable And Not _ForwardOnly Then
If _BOF Or _EOF Then _PropertyGet = Null Else _PropertyGet = RowSet.getBookmark()
Else
_PropertyGet = Null
If _ForwardOnly Then Goto Trace_Forward
End If
Case UCase("EditMode")
If IsNull(RowSet) Then Goto Trace_Closed
_PropertyGet = _EditMode
Case UCase("EOF")
If IsNull(RowSet) Then Goto Trace_Closed
Select Case True
Case _BOF And _EOF : _PropertyGet = True
Case RowSet.isAfterLast() : _PropertyGet = True
Case Else : _PropertyGet = False
End Select
Case UCase("Filter")
If IsNull(RowSet) Then Goto Trace_Closed
_PropertyGet = RowSet.Filter
Case UCase("LastModified")
If IsNull(RowSet) Then Goto Trace_Closed
If RowSet.IsBookmarkable And Not _ForwardOnly Then
_PropertyGet = _BookmarkLastModified
Else
_PropertyGet = Null
If _ForwardOnly Then Goto Trace_Forward
End If
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("RecordCount")
If IsNull(RowSet) Then Goto Trace_Closed
_PropertyGet = RowSet.RowCount
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Forward:
TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0)
Goto Exit_Function
Trace_Closed:
TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev Recordset _PropertySet Basic AbsolutePosition (Procedure)
Bookmark (Procedure)
Filter (Procedure)
setProperty (Procedure)
49
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean

Dim cstThisSub As String
cstThisSub = "Recordset.set"
Utils._SetCalledSub(cstThisSub & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function
_PropertySet = True

'Execute
Dim iArgNr As Integer
Dim oObject As Object

If _IsLeft(_A2B_.CalledSub, "Recordset.") Then iArgNr = 1 Else iArgNr = 2
Select Case UCase(psProperty)
Case UCase("AbsolutePosition")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
If pvValue < 1 Then Goto Trace_Error_Value
_Move(pvValue, , True)
Case UCase("Bookmark")
If IsNull(RowSet) Then Goto Trace_Closed
_Move(0, pvValue)
Case UCase("Filter")
If IsNull(RowSet) Then Goto Trace_Closed
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
_Filter = _ParentDatabase._ReplaceSquareBrackets(pvValue)
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub(cstThisSub & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Trace_Closed:
TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev Recordset AbsolutePosition Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AbsolutePosition() As Variant
AbsolutePosition = _PropertyGet("AbsolutePosition")
End Property ' AbsolutePosition (get)

Property Let AbsolutePosition(ByVal pvValue As Variant)
Call _PropertySet("AbsolutePosition", pvValue)
End Property ' AbsolutePosition (set)
Access2BaseDev Recordset AddNew Basic   134
REM -----------------------------------------------------------------------------------------------------------------------
Public Function AddNew() As Boolean
' Initiates the creation of a new record

Const cstThisSub = "Recordset.AddNew"
Dim i As Integer, iFieldsCount As Integer, oField As Object
Dim sDefault As String, oColumn As Object
Dim iValue As Integer, lValue As Long, sgValue As Single, dbValue As Double, dValue As Date
Dim vTemp As Variant
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
AddNew = False

With RowSet
'Is inserting a new row allowed ?
If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate
If Not .CanUpdateInsertedRows Then Goto Error_NoUpdate
If Not .IsBookmarkable Then Goto Error_NoUpdate
If _EditMode <> dbEditNone Then CancelUpdate()
If _BOF And _EOF Then ' Records before first or after last do not have a bookmark
_BookmarkBeforeNew = "_BOF_"
ElseIf .isBeforeFirst() Then
_BookmarkBeforeNew = "_BOF_"
ElseIf .isAfterLast() Then
_BookmarkBeforeNew = "_EOF_"
Else
_BookmarkBeforeNew = .getBookmark()
End If

.moveToInsertRow()

'Set all fields to their default value
iFieldsCount = Fields().Count
On Local Error Resume Next ' Do not stop if default setting fails
For i = 0 To iFieldsCount - 1
Set oField = Fields(i)
Set oColumn = oField.Column
sDefault = oField.DefaultValue
If sDefault = "" Then ' No default value
If oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then oColumn.updateNull()
Else
With com.sun.star.sdbc.DataType
Select Case oColumn.Type
Case .BIT, .BOOLEAN
If sDefault = "1" Then oColumn.updateBoolean(True) Else oColumn.updateBoolean(False)
Case .TINYINT
iValue = CInt(sDefault)
If iValue >= -128 And iValue <= +127 Then oColumn.updateShort(iValue)
Case .SMALLINT
lValue = CLng(sDefault)
If lValue >= -32768 And lValue <= 32767 Then oColumn.updateInt(lValue)
Case .INTEGER
lValue = CLng(sDefault)
If lValue >= -2147483648 And lValue <= 2147483647 Then oColumn.updateInt(lValue)
Case .BIGINT
lValue = CLng(sDefault)
Column.updateLong(lValue) ' No proper type conversion for HYPER data type
Case .FLOAT
sgValue = CSng(sDefault)
If Abs(sgValue) < 3.402823E38 And Abs(sgValue) > 1.401298E-45 Then oColumn.updateFloat(sgValue)
Case .REAL, .DOUBLE
dbValue = CDbl(sDefault)
'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue)
oColumn.updateDouble(dbValue)
Case .NUMERIC, .DECIMAL
dbValue = CDbl(sDefault)
If Utils._hasUNOProperty(Column, "Scale") Then
If Column.Scale > 0 Then
'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue)
oColumn.updateDouble(dbValue)
Else
oColumn.updateString(sDefault)
End If
Else
oColumn.updateString(sDefault)
End If
Case .CHAR, .VARCHAR, .LONGVARCHAR
oColumn.updateString(sDefault) ' vbString
Case .DATE
dValue = DateValue(sDefault)
vTemp = New com.sun.star.util.Date
With vTemp
.Day = Day(dValue)
.Month = Month(dValue)
.Year = Year(dValue)
End With
oColumn.updateDate(vTemp)
Case .TIME
dValue = TimeValue(sDefault)
vTemp = New com.sun.star.util.Time
With vTemp
.Hours = Hour(dValue)
.Minutes = Minute(dValue)
.Seconds = Second(dValue)
'.HundredthSeconds = 0
End With
oColumn.updateTime(vTemp)
Case .TIMESTAMP
dValue = DateValue(sDefault)
vTemp = New com.sun.star.util.DateTime
With vTemp
.Day = Day(dValue)
.Month = Month(dValue)
.Year = Year(dValue)
.Hours = Hour(dValue)
.Minutes = Minute(dValue)
.Seconds = Second(dValue)
'.HundredthSeconds = 0
End With
oColumn.updateTimestamp(vTemp)
' Case .BINARY, .VARBINARY, .LONGVARBINARY
' Case .BLOB
' Case .CLOB
Case Else
End Select
End With
End If
Next i
End With
If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0

_EditMode = dbEditAdd
AddNew = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' AddNew
Access2BaseDev Recordset BOF Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get BOF() As Boolean
BOF = _PropertyGet("BOF")
End Property ' BOF (get)
Access2BaseDev Recordset Bookmark Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Bookmark() As Variant
Bookmark = _PropertyGet("Bookmark")
End Property ' Bookmark (get)

Property Let Bookmark(ByVal pvValue As Variant)
Call _PropertySet("Bookmark", pvValue)
End Property ' Bookmark (set)
Access2BaseDev Recordset Bookmarkable Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Bookmarkable() As Boolean
Bookmarkable = _PropertyGet("Bookmarkable")
End Property ' Bookmarkable (get)
Access2BaseDev Recordset CancelUpdate Basic AddNew (Procedure)
Delete (Procedure)
Edit (Procedure)
GetRows (Procedure)
_Move (Procedure)
40
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CancelUpdate() As Boolean
' Cancel any edit action

Const cstThisSub = "Recordset.CancelUpdate"

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
CancelUpdate = False

With RowSet
Select Case _EditMode
Case dbEditNone
Case dbEditAdd
_AppendChunkClose(True)
If Not IsNull(_BookmarkBeforeNew) Then
Select Case _BookmarkBeforeNew
Case "_BOF_" : .beforeFirst()
Case "_EOF_" : .afterLast()
Case Else : .moveToBookmark(_BookmarkBeforeNew)
End Select
End If
Case dbEditInProgress
.cancelRowUpdates()
_AppendChunkClose(True)
End Select
End With

_EditMode = dbEditNone
_BookmarkBeforeNew = Null
_BookmarkLastModified = Null
CancelUpdate = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' CancelUpdate
Access2BaseDev Recordset Class_Initialize Basic   27
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJRECORDSET
_Name = ""
Set _This = Nothing
_Fields = Array()
_ParentName = ""
Set _ParentDatabase = Nothing
_ParentType = ""
_ForwardOnly = False
_PassThrough = False
_ReadOnly = False
_CommandType = 0
_Command = ""
_DataSet = False
_BOF = True
_EOF = True
_Filter = ""
_EditMode = dbEditNone
_BookmarkBeforeNew = Null
_BookmarkLastModified = Null
_IsClone = False
Set _ManageChunks = Array()
Set RowSet = Nothing
End Sub ' Constructor
Access2BaseDev Recordset Class_Terminate Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
mClose()
End Sub
Access2BaseDev Recordset Clone Basic   29
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Clone() As Object
' Duplicate an existing recordset

Const cstThisSub = "Recordset.Clone"

Const cstNull = -1
Dim iType As Integer, iOptions As Integer, iLockEdit As Integer
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
Set Clone = Nothing

If _IsClone Then Goto Error_Clone
If _ForwardOnly Then iType = dbOpenForwardOnly Else iType = cstNull
If _PassThrough Then iOptions = dbSQLPassThrough Else iOptions = cstNull
iLockEdit = dbReadOnly ' Always read-only

Set Clone = OpenRecordset(iType, iOptions, iLockEdit, True)

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_Clone:
TraceError(TRACEFATAL, ERRRECORDSETCLONE, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Clone
Access2BaseDev Recordset Delete Basic   37
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Delete() As Boolean
' Deletes the current record

Const cstThisSub = "Recordset.Delete"

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
Delete = False

'Is deleting a row allowed ?
If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate
If _EditMode <> dbEditNone Then
CancelUpdate()
Goto Error_Sequence
End If
If RowSet.rowDeleted() Then Goto Error_RowDeleted

RowSet.deleteRow()
Delete = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
Error_RowDeleted:
TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0)
Goto Exit_Function
Error_Sequence:
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
Goto Exit_Function
End Function ' Delete
Access2BaseDev Recordset Edit Basic   31
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Edit() As Boolean
' Updates the current record

Const cstThisSub = "Recordset.Edit"

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
Edit = False

'Is updating a row allowed ?
If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate
If _EditMode <> dbEditNone Then CancelUpdate()
If RowSet.rowDeleted() Then Goto Error_RowDeleted

_EditMode = dbEditInProgress
Edit = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
Error_RowDeleted:
TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Edit
Access2BaseDev Recordset EditMode Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get EditMode() As Integer
EditMode = _PropertyGet("EditMode")
End Property ' EditMode (get)
Access2BaseDev Recordset EOF Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get EOF() As Boolean
EOF = _PropertyGet("EOF")
End Property ' EOF (get)
Access2BaseDev Recordset Fields Basic AddNew (Procedure) 85
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Fields(ByVal Optional pvIndex As variant) As Object

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Recordset.Fields"
Utils._SetCalledSub(cstThisSub)

Set Fields = Nothing
If Not IsMissing(pvIndex) Then
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, oFields As Object, iIndex As Integer

' No argument, return a collection
If IsMissing(pvIndex) Then
Set oObject = New Collect
oObject._CollType = COLLFIELDS
oObject._ParentType = OBJRECORDSET
oObject._ParentName = _Name
Set oObject._ParentDatabase = _ParentDatabase
oObject._Count = RowSet.getColumns().Count
Goto Exit_Function
End If

Set oFields = RowSet.getColumns()
sObjects = oFields.ElementNames()

' Argument is the field name
If VarType(pvIndex) = vbString Then
iIndex = -1
' Check existence of object and find its exact (case-sensitive) name
For i = 0 To UBound(sObjects)
If UCase(pvIndex) = UCase(sObjects(i)) Then
sObjectName = sObjects(i)
iIndex = i
Exit For
End If
Next i
If iIndex < 0 Then Goto Trace_NotFound
' Argument is numeric
Else
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
sObjectName = sObjects(pvIndex)
iIndex = pvIndex
End If

' Check if field object already buffered in _Fields() array
If UBound(_Fields) < 0 Then ' Initialize _Fields
ReDim _Fields(0 To UBound(sObjects))
For i = 0 To UBound(sObjects)
Set _Fields(i) = Nothing
Next i
End If
If Not IsNull(_Fields(iIndex)) Then
Set oObject = _Fields(iIndex)
' Otherwise create new field object
Else
Set oObject = New Field
oObject._Name = sObjectName
Set oObject.Column = oFields.getByName(sObjectName)
If Utils._hasUNOProperty(oObject.Column, "Precision") Then oObject._Precision = oObject.Column.Precision
oObject._ParentName = _Name
oObject._ParentType = _Type
Set oObject._ParentDatabase = _ParentDatabase
Set oObject._ParentRecordset = _This
Set _Fields(iIndex) = oObject
End If

Exit_Function:
Set Fields = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Fields
Access2BaseDev Recordset Filter Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Filter() As Variant
Filter = _PropertyGet("Filter")
End Property ' Filter (get)

Property Let Filter(ByVal pvValue As Variant)
Call _PropertySet("Filter", pvValue)
End Property ' Filter (set)
Access2BaseDev Recordset getProperty Basic   11
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Const cstThisSub = "Recordset.getProperty"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub(cstThisSub)

End Function ' getProperty
Access2BaseDev Recordset GetRows Basic   54
REM -----------------------------------------------------------------------------------------------------------------------
Public Function GetRows(ByVal Optional pvNumRows As variant, ByVal Optional pbStrDate As Boolean) As Variant
' UNPUBLISHED - pbStrDate = True forces all dates to be converted into strings

If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Recordset.GetRows"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pbStrDate) Then pbStrDate = False

Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer
vMatrix() = Array()
If IsMissing(pvNumRows) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvNumRows, 1, Utils._AddNumeric()) Then Goto Exit_Function
If pvNumRows < 1 Then Goto Trace_Error
If IsNull(RowSet) Then Goto Trace_Closed
If Not _DataSet Then Goto Exit_Function

If _EditMode <> dbEditNone Then CancelUpdate()

If _EOF Then Goto Exit_Function

lSize = -1
iNumFields = RowSet.getColumns().Count - 1
If iNumFields < 0 Then Goto Exit_Function

ReDim vMatrix(0 To iNumFields, 0 To pvNumRows - 1)

Do While Not _EOF And lSize < pvNumRows - 1
lSize = lSize + 1
For i = 0 To iNumFields
vMatrix(i, lSize) = _getResultSetColumnValue(RowSet, i + 1)
If pbStrDate And IsDate(vMatrix(i, lSize)) Then vMatrix(i, lSize) = _CStr(vMatrix(i, lSize))
Next i
_Move("NEXT")
Loop
If lSize < pvNumRows - 1 Then ' Resize to number of fetched records
ReDim Preserve vMatrix(0 To iNumFields, 0 To lSize)
End If

Exit_Function:
GetRows() = vMatrix()
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_Error:
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvNumRows))
Set Controls = Nothing
Goto Exit_Function
Trace_Closed:
TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' GetRows V1.1.0
Access2BaseDev Recordset hasProperty Basic   11
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)

Const cstThisSub = "Recordset.hasProperty"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
Utils._ResetCalledSub(cstThisSub)
Exit Function

End Function ' hasProperty
Access2BaseDev Recordset LastModified Basic   5
REM -----------------------------------------------------------------------------------------------------------------------
Property Get LastModified() As Variant
' DO NOT PUBLISH
LastModified = _PropertyGet("LastModified")
End Property ' LastModified (get)
Access2BaseDev Recordset mClose Basic Class_Terminate (Procedure)
_Move (Procedure)
45
REM -----------------------------------------------------------------------------------------------------------------------
Public Function mClose(ByVal Optional pbRemove As Boolean) As Variant
' Dispose UNO objects
' If pbRemove = True, remove recordset from Recordsets collection

Const cstThisSub = "Recordset.Close"
Dim i As Integer

If _ErrorHandler() Then On Local Error Goto Exit_Function ' Do not stop execution
Utils._SetCalledSub(cstThisSub)
If Not IsNull(RowSet) Then
RowSet.close()
RowSet.dispose()
End If
_ForwardOnly = False
_PassThrough = False
_ReadOnly = False
_CommandType = 0
_Command = ""
_ParentName = ""
_ParentType = ""
_DataSet = False
_BOF = True
_EOF = True
_Filter = ""
_EditMode = dbEditNone
_BookmarkBeforeNew = Null
_BookmarkLastModified = Null
_IsClone = False
For i = 0 To UBound(_Fields)
If Not IsNull(_Fields(i)) Then
_Fields(i).Dispose()
Set _Fields(i) = Nothing
End If
Next i
_Fields = Array()
Set RowSet = Nothing
If IsMissing(pbRemove) Then pbRemove = True
If pbRemove Then _ParentDatabase.RecordsetsColl.Remove(_Name)
Set _ParentDatabase = Nothing

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Close
Access2BaseDev Recordset Move Basic   12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Move(ByVal Optional pvRelative As Variant, ByVal Optional pvBookmark As variant) As Boolean
' Move record pointer Relative rows vs. bookmark or current record

If IsMissing(pvRelative) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvRelative, 1, Utils._AddNumeric()) Then Goto Exit_Function

If IsMissing(pvBookmark) Then Move = _Move(pvRelative) Else Move = _Move(pvRelative, pvBookmark)

Exit_Function:
Exit Function
End Function ' Move
Access2BaseDev Recordset MoveFirst Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function MoveFirst() As Boolean
MoveFirst = _Move("First")
End Function ' MoveFirst
Access2BaseDev Recordset MoveLast Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function MoveLast() As Boolean
MoveLast = _Move("Last")
End Function ' MoveLast
Access2BaseDev Recordset MoveNext Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function MoveNext() As Boolean
MoveNext = _Move("Next")
End Function ' MoveNext
Access2BaseDev Recordset MovePrevious Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function MovePrevious() As Boolean
MovePrevious = _Move("Previous")
End Function ' MovePrevious
Access2BaseDev Recordset Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev Recordset ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev Recordset OpenRecordset Basic Clone (Procedure) 67
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenRecordset(ByVal Optional pvType As Variant _
, ByVal Optional pvOptions As Variant _
, ByVal Optional pvLockEdit As Variant _
, ByVal Optional pbClone As Boolean) As Object
'Return a Recordset object based on current recordset object with filter addition

If _ErrorHandler() Then On Local Error Goto Error_Function
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".OpenRecordset"
Utils._SetCalledSub(cstThisSub)
Set OpenRecordset = Nothing
Const cstNull = -1

Dim oObject As Object
Set oObject = Nothing
If IsMissing(pvType) Then
pvType = cstNull
Else
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
End If
If IsMissing(pvOptions) Then
pvOptions = cstNull
Else
If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
End If
If IsMissing(pvLockEdit) Then
pvLockEdit = cstNull
Else
If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
End If
If IsMissing(pbClone) Then pbClone = False ' pbClone is a not published argument

Set oObject = New Recordset
With oObject
._CommandType = _CommandType
._Command = _Command
._ParentName = _Name
._ParentType = _Type
Set ._ParentDatabase = _ParentDatabase
Set ._This = oObject
._ForwardOnly = ( pvType = dbOpenForwardOnly )
._PassThrough = ( pvOptions = dbSQLPassThrough )
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
Select Case True
Case pbClone : Call ._Initialize(, RowSet)
Case _Filter <> "" : Call ._Initialize(_Filter)
Case Else : Call ._Initialize()
End Select
End With
With _ParentDatabase
.RecordsetMax = .RecordsetMax + 1
oObject._Name = Format(.RecordsetMax, "0000000")
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
End With

If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty

Exit_Function:
Set OpenRecordset = oObject
Set oObject = Nothing
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
GoTo Exit_Function
End Function ' OpenRecordset
Access2BaseDev Recordset Properties Basic   24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise

Const cstThisSub = "Recordset.Properties"
Utils._SetCalledSub(cstThisSub)
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If
Set vProperty._ParentDatabase = _ParentDatabase

Exit_Function:
Set Properties = vProperty
Utils._ResetCalledSub(cstThisSub)
Exit Function
End Function ' Properties
Access2BaseDev Recordset RecordCount Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get RecordCount() As Long
RecordCount = _PropertyGet("RecordCount")
End Property ' RecordCount (get)
Access2BaseDev Recordset setProperty Basic   8
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Const cstThisSub = "Recordset.setProperty"
Utils._SetCalledSub(cstThisSub)
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub(cstThisSub)
End Function
Access2BaseDev Recordset Update Basic   55
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Update() As Boolean
' Finalize the updates of the current record

Const cstThisSub = "Recordset.Update"

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
Update = False

'Is updating a row allowed ?
If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate
With RowSet
If .rowDeleted() Then Goto Error_RowDeleted
Select Case _EditMode
Case dbEditNone
Goto Trace_Error_Update
Case dbEditAdd
_AppendChunkClose(False)
If .IsNew And .IsModified Then .insertRow()
_BookmarkLastModified = .getBookmark()
If Not IsNull(_BookmarkBeforeNew) Then
Select Case _BookmarkBeforeNew
Case "_BOF_" : .beforeFirst()
Case "_EOF_" : .afterLast()
Case Else : .moveToBookmark(_BookmarkBeforeNew)
End Select
End If
Case dbEditInProgress
_AppendChunkClose(False)
If .IsModified Then
.updateRow()
_BookmarkLastModified = .getBookmark()
End If
End Select
End With
_EditMode = dbEditNone
Update = True

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NoUpdate:
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
Goto Exit_Function
Trace_Error_Update:
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
Goto Exit_Function
Error_RowDeleted:
TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0)
Goto Exit_Function
End Function ' Update
Access2BaseDev Root_ _CurrentDb Basic   24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant
REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use)
REM With 2 arguments return the corresponding entry in Root

Dim odbDatabase As Variant
If IsMissing(piDocEntry) Then
Set odbDatabase = CurrentDb()
Else
If Not IsArray(CurrentDoc) Then Goto Trace_Error
If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error
If piDocEntry > UBound(CurrentDoc) Then Goto Trace_Error
If piDbEntry > UBound(CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error
Set odbDatabase = CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database
End If
If IsNull(odbDatabase) Then GoTo Trace_Error

Exit_Function:
Set _CurrentDb = odbDatabase
Exit Function
Trace_Error:
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1)
Goto Exit_Function
End Function ' _CurrentDb
Access2BaseDev Root_ Class_Initialize Basic Class_Terminate (Procedure) 33
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
Dim vCurrentDoc() As Variant
VersionNumber = Access2Base_Version
ErrorHandler = True
MinimalTraceLevel = 0
TraceLogs() = Array()
TraceLogCount = 0
TraceLogLast = 0
TraceLogMaxEntries = 0
CalledSub = ""
DebugPrintShort = True
Locale = L10N._GetLocale()
ExcludeA2B = True
Set Introspection = CreateUnoService("com.sun.star.beans.Introspection")
Set TextSearch = CreateUnoService("com.sun.star.util.TextSearch")
SearchOptions = New com.sun.star.util.SearchOptions
With SearchOptions
.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
.searchFlag = 0
.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
End With
Set FindRecord = Nothing
Set StatusBar = Nothing
Set Dialogs = New Collection
Set TempVars = New Collection
vCurrentDoc() = Array()
ReDim vCurrentDoc(0 To 0)
Set vCurrentDoc(0) = Nothing
Set CurrentDoc() = vCurrentDoc()
End Sub ' Constructor
Access2BaseDev Root_ Class_Terminate Basic Dispose (Procedure) 4
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev Root_ CloseConnection Basic   41
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub CloseConnection()
' Close all connections established by current document to free memory.
' - if Base document => close the one concerned database connection
' - if non-Base documents => close the connections of each individual standalone form

Dim i As Integer, iCurrentDoc As Integer
Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant

If ErrorHandler Then On Local Error Goto Error_Sub

If Not IsArray(CurrentDoc) Then Goto Exit_Sub
If UBound(CurrentDoc) < 0 Then Goto Exit_Sub
iCurrentDoc = CurrentDocIndex( , False) ' False prevents error raising if not found
If iCurrentDoc < 0 Then GoTo Exit_Sub ' If not found ignore

vDocContainer = CurrentDocument(iCurrentDoc)
With vDocContainer
If Not .Active Then GoTo Exit_Sub ' e.g. if successive calls to CloseConnection()
For i = 0 To UBound(.DbContainers)
If Not IsNull(.DbContainers(i).Database) Then
.DbContainers(i).Database.Dispose()
Set .DbContainers(i).Database = Nothing
End If
TraceLog(TRACEANY, UCase(CalledSub) & " " & .URL & Iif(i = 0, "", " Form=" & .DbContainers(i).FormName), False)
Set .DbContainers(i) = Nothing
Next i
.DbContainers = Array()
.URL = ""
.DbConnect = 0
.Active = False
Set .Document = Nothing
End With
CurrentDoc(iCurrentDoc) = vDocContainer

Exit_Sub:
Exit Sub
Error_Sub:
TraceError(TRACEABORT, Err, CalledSub, Erl, False) ' No error message addressed to the user, only stored in console
GoTo Exit_Sub
End Sub ' CloseConnection
Access2BaseDev Root_ CurrentDb Basic _CurrentDb (Procedure) 18
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDb() As Object
' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties

Dim iCurrentDoc As Integer

Set CurrentDb = Nothing

If Not IsArray(CurrentDoc) Then Goto Exit_Function
If UBound(CurrentDoc) < 0 Then Goto Exit_Function
iCurrentDoc = CurrentDocIndex(, False) ' False = no abort
If iCurrentDoc >= 0 Then
If UBound(CurrentDoc(iCurrentDoc).DbContainers) >= 0 Then Set CurrentDb = CurrentDoc(iCurrentDoc).DbContainers(0).Database
End If

Exit_Function:
Exit Function
End Function ' CurrentDb
Access2BaseDev Root_ CurrentDocIndex Basic CloseConnection (Procedure)
CurrentDb (Procedure)
CurrentDocument (Procedure)
45
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDocIndex(Optional pvURL As Variant, Optional pbAbort As Variant) As Integer
' Returns the entry in CurrentDoc(...) referring to the current document

Dim i As Integer, bFound As Boolean, sURL As String
Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument"

bFound = False
CurrentDocIndex = -1

If Not IsArray(CurrentDoc) Then Goto Trace_Error
If UBound(CurrentDoc) < 0 Then Goto Trace_Error
For i = 1 To UBound(CurrentDoc) ' [0] reserved to database .odb document
If IsMissing(pvURL) Then ' Not on 1 single line ?!?
If Utils._hasUNOProperty(ThisComponent, "URL") Then
sURL = ThisComponent.URL
Else
Exit For ' f.i. ThisComponent = Basic IDE ...
End If
Else
sURL = pvURL ' To support the SelectObject action
End If
If CurrentDoc(i).Active And CurrentDoc(i).URL = sURL Then
CurrentDocIndex = i
bFound = True
Exit For
End If
Next i

If Not bFound Then
If IsNull(CurrentDoc(0)) Then GoTo Trace_Error
With CurrentDoc(0)
If Not .Active Then GoTo Trace_Error
If IsNull(.Document) Then GoTo Trace_Error
End With
CurrentDocIndex = 0
End If

Exit_Function:
Exit Function
Trace_Error:
If IsMissing(pbAbort) Then pbAbort = True
If pbAbort Then TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Else CurrentDocIndex = -1
Goto Exit_Function
End Function ' CurrentDocIndex
Access2BaseDev Root_ CurrentDocument Basic CloseConnection (Procedure) 9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDocument(ByVal Optional piDocIndex As Integer) As Variant
' Returns the CurrentDoc(...) referring to the current document or to the argument

Dim iDocIndex As Integer
If IsMissing(piDocIndex) Then iDocIndex = CurrentDocIndex(, False) Else iDocIndex = piDocIndex
If iDocIndex >= 0 And iDocIndex <= UBound(CurrentDoc) Then Set CurrentDocument = CurrentDoc(iDocIndex) Else Set CurrentDocument = Nothing

End Function
Access2BaseDev Root_ Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev Root_ Dump Basic   24
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dump()
' For debugging purposes
Dim i As Integer, j As Integer, vCurrentDoc As Variant
On Local Error Resume Next

DebugPrint "Version", VersionNumber
DebugPrint "TraceLevel", MinimalTraceLevel
DebugPrint "TraceCount", TraceLogCount
DebugPrint "CalledSub", CalledSub
If IsArray(CurrentDoc) Then
For i = 0 To UBound(CurrentDoc)
vCurrentDoc = CurrentDoc(i)
If Not IsNull(vCurrentDoc) Then
DebugPrint i, "URL", vCurrentDoc.URL
For j = 0 To UBound(vCurrentDoc.DbContainers)
DebugPrint i, j, "Form", vCurrentDoc.DbContainers(j).FormName
DebugPrint i, j, "Database", vCurrentDoc.DbContainers(j).Database.Title
Next j
End If
Next i
End If

End Sub
Access2BaseDev Root_ hasItem Basic   23
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasItem(psCollType As String, ByVal psName As String) As Boolean
' Return True if psName if in the collection

Dim oItem As Object
On Local Error Goto Error_Function ' Whatever ErrorHandler !

hasItem = True
Select Case psCollType
Case COLLALLDIALOGS
Set oItem = Dialogs.Item(UCase(psName))
Case COLLTEMPVARS
Set oItem = TempVars.Item(UCase(psName))
Case Else
hasItem = False
End Select

Exit_Function:
Exit Function
Error_Function: ' Item by key aborted
hasItem = False
GoTo Exit_Function
End Function ' hasItem
Access2BaseDev SubForm _GetListener Basic _PropertySet (Procedure) 25
Private Function _GetListener(ByVal psProperty As String) As String
' Return the X...Listener corresponding with the property in argument

Select Case UCase(psProperty)
Case UCase("OnApproveCursorMove")
_GetListener = "XRowSetApproveListener"
Case UCase("OnApproveParameter")
_GetListener = "XDatabaseParameterListener"
Case UCase("OnApproveReset"), UCase("OnResetted")
_GetListener = "XResetListener"
Case UCase("OnApproveRowChange")
_GetListener = "XRowSetApproveListener"
Case UCase("OnApproveSubmit")
_GetListener = "XSubmitListener"
Case UCase("OnConfirmDelete")
_GetListener = "XConfirmDeleteListener"
Case UCase("OnCursorMoved"), UCase("OnRowChanged")
_GetListener = "XRowSetListener"
Case UCase("OnErrorOccurred")
_GetListener = "XSQLErrorListener"
Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading")
_GetListener = "XLoadListener"
End Select

End Function ' _GetListener V1.7.0
Access2BaseDev SubForm _PropertiesList Basic Properties (Procedure)
hasProperty (Procedure)
13
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

_PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "CurrentRecord" _
, "Filter", "FilterOn", "LinkChildFields", "LinkMasterFields", "Name" _
, "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _
, "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _
, "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _
, "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OrderBy" _
, "OrderByOn", "Parent", "RecordSource" _
) ' Recordset removed

End Function ' _PropertiesList
Access2BaseDev SubForm _PropertyGet Basic AllowAdditions (Procedure)
AllowDeletions (Procedure)
AllowEdits (Procedure)
CurrentRecord (Procedure)
Filter (Procedure)
FilterOn (Procedure)
LinkChildFields (Procedure)
LinkMasterFields (Procedure)
Name (Procedure)
pName (Procedure)
ObjectType (Procedure)
OnApproveCursorMove (Procedure)
OnApproveParameter (Procedure)
OnApproveReset (Procedure)
OnApproveRowChange (Procedure)
OnApproveSubmit (Procedure)
OnConfirmDelete (Procedure)
OnCursorMoved (Procedure)
OnErrorOccurred (Procedure)
OnLoaded (Procedure)
OnReloaded (Procedure)
OnReloading (Procedure)
OnResetted (Procedure)
OnRowChanged (Procedure)
OnUnloaded (Procedure)
OnUnloading (Procedure)
OrderBy (Procedure)
OrderByOn (Procedure)
Properties (Procedure)
Recordset (Procedure)
RecordSource (Procedure)
getProperty (Procedure)
110
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("SubForm.get" & psProperty)
Dim iArgNr As Integer
If Not IsMissing(pvIndex) Then
Select Case UCase(_A2B_.CalledSub)
Case UCase("getProperty") : iArgNr = 3
Case UCase("SubForm.getProperty") : iArgNr = 2
Case UCase("SubForm.get" & psProperty) : iArgNr = 1
End Select
If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
End If

'Execute
Dim oDatabase As Object, vBookmark As Variant, oObject As Object
_PropertyGet = EMPTY

Select Case UCase(psProperty)
Case UCase("AllowAdditions")
_PropertyGet = DatabaseForm.AllowInserts
Case UCase("AllowDeletions")
_PropertyGet = DatabaseForm.AllowDeletes
Case UCase("AllowEdits")
_PropertyGet = DatabaseForm.AllowUpdates
Case UCase("CurrentRecord")
_PropertyGet = DatabaseForm.Row
Case UCase("Filter")
_PropertyGet = DatabaseForm.Filter
Case UCase("FilterOn")
_PropertyGet = DatabaseForm.ApplyFilter
Case UCase("LinkChildFields")
If Utils._hasUNOProperty(DatabaseForm, "DetailFields") Then
If IsMissing(pvIndex) Then
_PropertyGet = DatabaseForm.DetailFields
Else
If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.DetailFields) Then Goto trace_Error_Index
_PropertyGet = DatabaseForm.DetailFields(pvIndex)
End If
End If
Case UCase("LinkMasterFields")
If Utils._hasUNOProperty(DatabaseForm, "MasterFields") Then
If IsMissing(pvIndex) Then
_PropertyGet = DatabaseForm.MasterFields
Else
If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.MasterFields) Then Goto trace_Error_Index
_PropertyGet = DatabaseForm.MasterFields(pvIndex)
End If
End If
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _
, UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _
, UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _
, UCase("OnUnloaded"), UCase("OnUnloading")
_PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name)
Case UCase("OrderBy")
_PropertyGet = _OrderBy
Case UCase("OrderByOn")
If DatabaseForm.Order = "" Then _PropertyGet = False Else _PropertyGet = True
Case UCase("Parent") ' Only for indirect access from property object
_PropertyGet = Parent
Case UCase("Recordset")
If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ??
Set oObject = New Recordset
With DatabaseForm
oObject._CommandType = .CommandType
oObject._Command = .Command
oObject._ParentName = _Name
oObject._ParentType = _Type
Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
Set oObject._ParentDatabase = oDatabase
Set oObject._ParentDatabase.Connection = .ActiveConnection
oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY )
oObject._PassThrough = ( .EscapeProcessing = False )
oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY )
Call oObject._Initialize()
End With
With oDatabase
.RecordsetMax = .RecordsetMax + 1
oObject._Name = Format(.RecordsetMax, "0000000")
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
End With
Set _PropertyGet = oObject
Case UCase("RecordSource")
_PropertyGet = DatabaseForm.Command
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("SubForm.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = EMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm._PropertyGet", Erl)
_PropertyGet = EMPTY
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev SubForm _PropertySet Basic AllowAdditions (Procedure)
AllowDeletions (Procedure)
AllowEdits (Procedure)
CurrentRecord (Procedure)
Filter (Procedure)
FilterOn (Procedure)
OnApproveCursorMove (Procedure)
OnApproveParameter (Procedure)
OnApproveReset (Procedure)
OnApproveRowChange (Procedure)
OnApproveSubmit (Procedure)
OnConfirmDelete (Procedure)
OnCursorMoved (Procedure)
OnErrorOccurred (Procedure)
OnLoaded (Procedure)
OnReloaded (Procedure)
OnReloading (Procedure)
OnResetted (Procedure)
OnRowChanged (Procedure)
OnUnloaded (Procedure)
OnUnloading (Procedure)
OrderBy (Procedure)
OrderByOn (Procedure)
RecordSource (Procedure)
setProperty (Procedure)
77
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean

Utils._SetCalledSub("SubForm.set" & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function
_PropertySet = True

'Execute
Dim iArgNr As Integer

If _IsLeft(_A2B_.CalledSub, "SubForm.") Then iArgNr = 1 Else iArgNr = 2
Select Case UCase(psProperty)
Case UCase("AllowAdditions")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
DatabaseForm.AllowInserts = pvValue
DatabaseForm.reload()
Case UCase("AllowDeletions")
If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
DatabaseForm.AllowDeletes = pvValue
DatabaseForm.reload()
Case UCase("AllowEdits")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
DatabaseForm.AllowUpdates = pvValue
DatabaseForm.reload()
Case UCase("CurrentRecord")
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
DatabaseForm.absolute(pvValue)
Case UCase("Filter")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
Case UCase("FilterOn")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
DatabaseForm.ApplyFilter = pvValue
DatabaseForm.reload()
Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _
, UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _
, UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _
, UCase("OnUnloaded"), UCase("OnUnloading")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
If Not Utils._RegisterEventScript(DatabaseForm _
, psProperty _
, _GetListener(psProperty) _
, pvValue, _Name _
) Then GoTo Trace_Error
Case UCase("OrderBy")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
_OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
Case UCase("OrderByOn")
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = ""
DatabaseForm.reload()
Case UCase("RecordSource")
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND
DatabaseForm.Filter = ""
DatabaseForm.reload()
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("SubForm.set" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev SubForm AllowAdditions Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AllowAdditions() As Variant
AllowAdditions = _PropertyGet("AllowAdditions")
End Property ' AllowAdditions (get)

Property Let AllowAdditions(ByVal pvValue As Variant)
Call _PropertySet("AllowAdditions", pvValue)
End Property ' AllowAdditions (set)
Access2BaseDev SubForm AllowDeletions Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AllowDeletions() As Variant
AllowDeletions = _PropertyGet("AllowDeletions")
End Property ' AllowDeletions (get)

Property Let AllowDeletions(ByVal pvValue As Variant)
Call _PropertySet("AllowDeletions", pvValue)
End Property ' AllowDeletions (set)
Access2BaseDev SubForm AllowEdits Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get AllowEdits() As Variant
AllowEdits = _PropertyGet("AllowEdits")
End Property ' AllowEdits (get)

Property Let AllowEdits(ByVal pvValue As Variant)
Call _PropertySet("AllowEdits", pvValue)
End Property ' AllowEdits (set)
Access2BaseDev SubForm Class_Initialize Basic Class_Terminate (Procedure) 14
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJSUBFORM
_Shortcut = ""
_Name = ""
_MainForm = ""
_DocEntry = -1
_DbEntry = -1
_OrderBy = ""
Set ParentComponent = Nothing
Set DatabaseForm = Nothing
End Sub ' Constructor
Access2BaseDev SubForm Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev SubForm Controls Basic   83
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
' Return a Control object with name or index = pvIndex

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("SubForm.Controls")

Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer
Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String
Dim j As Integer

Set ocControl = Nothing
iControlCount = DatabaseForm.getCount()

If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object
Set oCounter = New Collect
oCounter._CollType = COLLCONTROLS
oCounter._ParentType = OBJSUBFORM
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 = CTLPARENTISSUBFORM
sParentShortcut = _Shortcut
sControls() = DatabaseForm.getElementNames()

Select Case VarType(pvIndex)
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index
ocControl._Name = sControls(pvIndex)
Case vbString ' Check control name validity (non case sensitive)
bFound = False
sIndex = UCase(Utils._Trim(pvIndex))
For i = 0 To iControlCount - 1
If UCase(sControls(i)) = sIndex Then
bFound = True
Exit For
End If
Next i
If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound
End Select

With ocControl
._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name)
Set .ControlModel = DatabaseForm.getByName(._Name)
._ImplementationName = .ControlModel.getImplementationName()
._FormComponent = ParentComponent
If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId
If ._ClassId > 0 And ._ClassId <> acHiddenControl Then
Set .ControlView = ParentComponent.CurrentController.getControl(.ControlModel)
End If

._Initialize()
._DocEntry = _DocEntry
._DbEntry = _DbEntry
End With
Set Controls = ocControl

Exit_Function:
Utils._ResetCalledSub("SubForm.Controls")
Exit Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set Controls = Nothing
Goto Exit_Function
Trace_NotFound:
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name))
Set Controls = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm.Controls", Erl)
Set Controls = Nothing
GoTo Exit_Function
End Function ' Controls V1.1.0
Access2BaseDev SubForm CurrentRecord Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get CurrentRecord() As Variant
CurrentRecord = _PropertyGet("CurrentRecord")
End Property ' CurrentRecord (get)

Property Let CurrentRecord(ByVal pvValue As Variant)
Call _PropertySet("CurrentRecord", pvValue)
End Property ' CurrentRecord (set)
Access2BaseDev SubForm Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev SubForm Filter Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Filter() As Variant
Filter = _PropertyGet("Filter")
End Property ' Filter (get)

Property Let Filter(ByVal pvValue As Variant)
Call _PropertySet("Filter", pvValue)
End Property ' Filter (set)
Access2BaseDev SubForm FilterOn Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get FilterOn() As Variant
FilterOn = _PropertyGet("FilterOn")
End Property ' FilterOn (get)

Property Let FilterOn(ByVal pvValue As Variant)
Call _PropertySet("FilterOn", pvValue)
End Property ' FilterOn (set)
Access2BaseDev SubForm getProperty Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("SubForm.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("SubForm.getProperty")

End Function ' getProperty
Access2BaseDev SubForm hasProperty Basic   8
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
Access2BaseDev SubForm LinkChildFields Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get LinkChildFields(ByVal Optional pvIndex As Variant) As Variant
If IsMissing(pvIndex) Then LinkChildFields = _PropertyGet("LinkChildFields") Else LinkChildFields = _PropertyGet("LinkChildFields", pvIndex)
End Property ' LinkChildFields (get)
Access2BaseDev SubForm LinkMasterFields Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get LinkMasterFields(ByVal Optional pvIndex As Variant) As Variant
If IsMissing(pvIndex) Then LinkMasterFields = _PropertyGet("LinkMasterFields") Else LinkMasterFields = _PropertyGet("LinkMasterFields", pvIndex)
End Property ' LinkMasterFields (get)
Access2BaseDev SubForm Name Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev SubForm ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev SubForm OnApproveCursorMove Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveCursorMove() As Variant
OnApproveCursorMove = _PropertyGet("OnApproveCursorMove")
End Property ' OnApproveCursorMove (get)

Property Let OnApproveCursorMove(ByVal pvValue As Variant)
Call _PropertySet("OnApproveCursorMove", pvValue)
End Property ' OnApproveCursorMove (set)
Access2BaseDev SubForm OnApproveParameter Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveParameter() As Variant
OnApproveParameter = _PropertyGet("OnApproveParameter")
End Property ' OnApproveParameter (get)

Property Let OnApproveParameter(ByVal pvValue As Variant)
Call _PropertySet("OnApproveParameter", pvValue)
End Property ' OnApproveParameter (set)
Access2BaseDev SubForm OnApproveReset Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveReset() As Variant
OnApproveReset = _PropertyGet("OnApproveReset")
End Property ' OnApproveReset (get)

Property Let OnApproveReset(ByVal pvValue As Variant)
Call _PropertySet("OnApproveReset", pvValue)
End Property ' OnApproveReset (set)
Access2BaseDev SubForm OnApproveRowChange Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveRowChange() As Variant
OnApproveRowChange = _PropertyGet("OnApproveRowChange")
End Property ' OnApproveRowChange (get)

Property Let OnApproveRowChange(ByVal pvValue As Variant)
Call _PropertySet("OnApproveRowChange", pvValue)
End Property ' OnApproveRowChange (set)
Access2BaseDev SubForm OnApproveSubmit Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnApproveSubmit() As Variant
OnApproveSubmit = _PropertyGet("OnApproveSubmit")
End Property ' OnApproveSubmit (get)

Property Let OnApproveSubmit(ByVal pvValue As Variant)
Call _PropertySet("OnApproveSubmit", pvValue)
End Property ' OnApproveSubmit (set)
Access2BaseDev SubForm OnConfirmDelete Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnConfirmDelete() As Variant
OnConfirmDelete = _PropertyGet("OnConfirmDelete")
End Property ' OnConfirmDelete (get)

Property Let OnConfirmDelete(ByVal pvValue As Variant)
Call _PropertySet("OnConfirmDelete", pvValue)
End Property ' OnConfirmDelete (set)
Access2BaseDev SubForm OnCursorMoved Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnCursorMoved() As Variant
OnCursorMoved = _PropertyGet("OnCursorMoved")
End Property ' OnCursorMoved (get)

Property Let OnCursorMoved(ByVal pvValue As Variant)
Call _PropertySet("OnCursorMoved", pvValue)
End Property ' OnCursorMoved (set)
Access2BaseDev SubForm OnErrorOccurred Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnErrorOccurred() As Variant
OnErrorOccurred = _PropertyGet("OnErrorOccurred")
End Property ' OnErrorOccurred (get)

Property Let OnErrorOccurred(ByVal pvValue As Variant)
Call _PropertySet("OnErrorOccurred", pvValue)
End Property ' OnErrorOccurred (set)
Access2BaseDev SubForm OnLoaded Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnLoaded() As Variant
OnLoaded = _PropertyGet("OnLoaded")
End Property ' OnLoaded (get)

Property Let OnLoaded(ByVal pvValue As Variant)
Call _PropertySet("OnLoaded", pvValue)
End Property ' OnLoaded (set)
Access2BaseDev SubForm OnReloaded Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnReloaded() As Variant
OnReloaded = _PropertyGet("OnReloaded")
End Property ' OnReloaded (get)

Property Let OnReloaded(ByVal pvValue As Variant)
Call _PropertySet("OnReloaded", pvValue)
End Property ' OnReloaded (set)
Access2BaseDev SubForm OnReloading Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnReloading() As Variant
OnReloading = _PropertyGet("OnReloading")
End Property ' OnReloading (get)

Property Let OnReloading(ByVal pvValue As Variant)
Call _PropertySet("OnReloading", pvValue)
End Property ' OnReloading (set)
Access2BaseDev SubForm OnResetted Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnResetted() As Variant
OnResetted = _PropertyGet("OnResetted")
End Property ' OnResetted (get)

Property Let OnResetted(ByVal pvValue As Variant)
Call _PropertySet("OnResetted", pvValue)
End Property ' OnResetted (set)
Access2BaseDev SubForm OnRowChanged Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnRowChanged() As Variant
OnRowChanged = _PropertyGet("OnRowChanged")
End Property ' OnRowChanged (get)

Property Let OnRowChanged(ByVal pvValue As Variant)
Call _PropertySet("OnRowChanged", pvValue)
End Property ' OnRowChanged (set)
Access2BaseDev SubForm OnUnloaded Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnloaded() As Variant
OnUnloaded = _PropertyGet("OnUnloaded")
End Property ' OnUnloaded (get)

Property Let OnUnloaded(ByVal pvValue As Variant)
Call _PropertySet("OnUnloaded", pvValue)
End Property ' OnUnloaded (set)
Access2BaseDev SubForm OnUnloading Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnloading() As Variant
OnUnloading = _PropertyGet("OnUnloading")
End Property ' OnUnloading (get)

Property Let OnUnloading(ByVal pvValue As Variant)
Call _PropertySet("OnUnloading", pvValue)
End Property ' OnUnloading (set)
Access2BaseDev SubForm OptionGroup Basic   24
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant
' Return either an error or an object of type OPTIONGROUP based on its name

Const cstThisSub = "SubForm.OptionGroup"
Dim ogGroup As Object
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvGroupName) Then Call _TraceArguments()
If _ErrorHandler() Then On Local Error Goto Error_Function

Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, ParentComponent, DatabaseForm)
If Not IsNull(ogGroup) Then
ogGroup._DocEntry = _DocEntry
ogGroup._DbEntry = _DbEntry
End If
Set OptionGroup = ogGroup

Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
End Function ' OptionGroup V1.1.0
Access2BaseDev SubForm OrderBy Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OrderBy() As Variant
OrderBy = _PropertyGet("OrderBy")
End Property ' OrderBy (get) V1.2.0

Property Let OrderBy(ByVal pvValue As Variant)
Call _PropertySet("OrderBy", pvValue)
End Property ' OrderBy (set)
Access2BaseDev SubForm OrderByOn Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get OrderByOn() As Variant
OrderByOn = _PropertyGet("OrderByOn")
End Property ' OrderByOn (get) V1.2.0

Property Let OrderByOn(ByVal pvValue As Variant)
Call _PropertySet("OrderByOn", pvValue)
End Property ' OrderByOn (set)
Access2BaseDev SubForm Parent Basic _PropertyGet (Procedure) 16
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Parent() As Object

Utils._SetCalledSub("SubForm.getParent")
On Error Goto Error_Function

Set Parent = PropertiesGet._ParentObject(_Shortcut)

Exit_Function:
Utils._ResetCalledSub("SubForm.getParent")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm.getParent", Erl)
Set Parent = Nothing
GoTo Exit_Function
End Function ' Parent
Access2BaseDev SubForm pName Basic   3
Public Function pName() As String		'	For compatibility with < V0.9.0
pName = _PropertyGet("Name")
End Function ' pName (get)
Access2BaseDev SubForm Properties Basic   20
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, _Shortcut, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Shortcut, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev SubForm Recordset Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Recordset() As Object
Recordset = _PropertyGet("Recordset")
End Property ' Recordset (get) V0.9.5
Access2BaseDev SubForm RecordSource Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Property Get RecordSource() As Variant
RecordSource = _PropertyGet("RecordSource")
End Property ' RecordSource (get)

Property Let RecordSource(ByVal pvValue As Variant)
Call _PropertySet("RecordSource", pvValue)
End Property ' RecordSource (set)
Access2BaseDev SubForm Refresh Basic   22
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Refresh() As Boolean
' Refresh data with its most recent value in the database in a form or subform
Utils._SetCalledSub("SubForm.Refresh")
If _ErrorHandler() Then On Local Error Goto Error_Function
Refresh = False

Dim oSet As Object
Set oSet = DatabaseForm.createResultSet()
If Not IsNull(oSet) Then
oSet.refreshRow()
Refresh = True
End If

Exit_Function:
Set oSet = Nothing
Utils._ResetCalledSub("SubForm.Refresh")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl)
GoTo Exit_Function
End Function ' Refresh
Access2BaseDev SubForm Requery Basic   17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Requery() As Boolean
' Refresh data displayed in a form, subform, combobox or listbox
Utils._SetCalledSub("SubForm.Requery")
If _ErrorHandler() Then On Local Error Goto Error_Function
Requery = False

DatabaseForm.reload()
Requery = True

Exit_Function:
Utils._ResetCalledSub("SubForm.Requery")
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, "SubForm.Requery", Erl)
GoTo Exit_Function
End Function ' Requery
Access2BaseDev SubForm setProperty Basic   7
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Utils._SetCalledSub("SubForm.setProperty")
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub("SubForm.setProperty")
End Function
Access2BaseDev TempVar _PropertiesList Basic hasProperty (Procedure)
Properties (Procedure)
6
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
_PropertiesList = Array("Name", "ObjectType", "Value")
End Function ' _PropertiesList
Access2BaseDev TempVar _PropertyGet Basic Name (Procedure)
ObjectType (Procedure)
Value (Procedure)
getProperty (Procedure)
Properties (Procedure)
31
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("TempVar.get" & psProperty)
_PropertyGet = Nothing

Select Case UCase(psProperty)
Case UCase("Name")
_PropertyGet = _Name
Case UCase("ObjectType")
_PropertyGet = _Type
Case UCase("Value")
_PropertyGet = _Value
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("TempVar.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "TempVar._PropertyGet", Erl)
_PropertyGet = Nothing
GoTo Exit_Function
End Function ' _PropertyGet
Access2BaseDev TempVar _PropertySet Basic Value (Procedure)
setProperty (Procedure)
35
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean

Utils._SetCalledSub("TempVar.set" & psProperty)
If _ErrorHandler() Then On Local Error Goto Error_Function
_PropertySet = True

'Execute
Dim iArgNr As Integer

If _IsLeft(_A2B_.CalledSub, "TempVar.") Then iArgNr = 1 Else iArgNr = 2
Select Case UCase(psProperty)
Case UCase("Value")
_Value = pvValue
_A2B_.TempVars.Item(UCase(_Name)).Value = pvValue
Case Else
Goto Trace_Error
End Select

Exit_Function:
Utils._ResetCalledSub("TempVar.set" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
_PropertySet = False
Goto Exit_Function
Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "TempVar._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
End Function ' _PropertySet
Access2BaseDev TempVar Class_Initialize Basic Class_Terminate (Procedure) 8
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJTEMPVAR
_Name = ""
_Value = Null
End Sub ' Constructor
Access2BaseDev TempVar Class_Terminate Basic Dispose (Procedure) 5
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
Access2BaseDev TempVar Dispose Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
Access2BaseDev TempVar getProperty Basic   9
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Utils._SetCalledSub("Property.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Property.getProperty")

End Function ' getProperty
Access2BaseDev TempVar hasProperty Basic   8
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
Access2BaseDev TempVar Name Basic   3
Property Get Name() As String
Name = _PropertyGet("Name")
End Property ' Name (get)
Access2BaseDev TempVar ObjectType Basic   4
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
Access2BaseDev TempVar Properties Basic   20
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, _Name, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If

Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
Access2BaseDev TempVar setProperty Basic   9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
' Return True if property setting OK
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".getProperty"
Utils._SetCalledSub(cstThisSub)
setProperty = _PropertySet(psProperty, pvValue)
Utils._ResetCalledSub(cstThisSub)
End Function
Access2BaseDev TempVar Value Basic   7
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)
Access2BaseDev Test Main Basic   7
Sub Main
Dim a, b()
_ErrorHandler(False)
' DebugPrint vbLF
' TraceConsole()
exit sub
End Sub
Access2BaseDev Trace _DumpToFile Basic   32
Private Sub _DumpToFile(oEvent As Object)
' Execute the Dump To File command from the Trace dialog
' Modified from Andrew Pitonyak's Base Macro Programming §10.4


If _ErrorHandler() Then On Local Error GoTo Error_Sub

Dim sPath as String, iFileNumber As Integer, i As Integer

sPath = _PromptFilePicker("txt")
If sPath <> "" Then ' Save button pressed
If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized
iFileNumber = FreeFile()
Open sPath For Append Access Write Lock Read As iFileNumber
If _A2B_.TraceLogCount > 0 Then
If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast
Do
If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0
Print #iFileNumber _A2B_.TraceLogs(i)
Loop While i <> _A2B_.TraceLogLast
End If
Close iFileNumber
MsgBox _GetLabel("SAVECONSOLEENTRIES"), vbOK + vbInformation, _GetLabel("SAVECONSOLE")
End If
End If

Exit_Sub:
Exit Sub
Error_Sub:
TraceError("ERROR", Err, "DumpToFile", Erl)
GoTo Exit_Sub
End Sub ' DumpToFile V0.8.5
Access2BaseDev Trace _ErrorHandler Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CommandBars (Procedure)
Controls (Procedure)
Events (Procedure)
Forms (Procedure)
HtmlEncode (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
AddItem (Procedure)
Move (Procedure)
Refresh (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
SetFocus (Procedure)
_OptionGroup (Procedure)
Main (Procedure)
TraceConsole (Procedure)
TraceLevel (Procedure)
TraceLog (Procedure)
_DumpToFile (Procedure)
_PromptFilePicker (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindNext (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OpenQuery (Procedure)
OpenReport (Procedure)
OpenSQL (Procedure)
OpenTable (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunApp (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
_OpenObject (Procedure)
_SelectWindow (Procedure)
_SendWithAttachment (Procedure)
_SendWithoutAttachment (Procedure)
_getTempDirectoryURL (Procedure)
_IsPseudo (Procedure)
mClose (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_DFunction (Procedure)
_hasRecordset (Procedure)
_OutputToCalc (Procedure)
_PropertyGet (Procedure)
_setProperty (Procedure)
Add (Procedure)
Delete (Procedure)
Remove (Procedure)
RemoveAll (Procedure)
_PropertyGet (Procedure)
getObject (Procedure)
getOptionGroup (Procedure)
_getProperty (Procedure)
IsLoaded (Procedure)
OptionGroup (Procedure)
mClose (Procedure)
Controls (Procedure)
Move (Procedure)
Refresh (Procedure)
Requery (Procedure)
setFocus (Procedure)
_Initialize (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Controls (Procedure)
Refresh (Procedure)
Requery (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_Initialize (Procedure)
_PropertyGet (Procedure)
_PropertyGet (Procedure)
AddItem (Procedure)
Controls (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
setFocus (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Start (Procedure)
Terminate (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AppendChunk (Procedure)
GetChunk (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_ReadAll (Procedure)
_WriteAll (Procedure)
CreateField (Procedure)
Fields (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AddNew (Procedure)
CancelUpdate (Procedure)
Clone (Procedure)
mClose (Procedure)
Delete (Procedure)
Edit (Procedure)
Fields (Procedure)
GetRows (Procedure)
OpenRecordset (Procedure)
Update (Procedure)
_AppendChunk (Procedure)
_AppendChunkClose (Procedure)
_Initialize (Procedure)
_Move (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CommandBarControls (Procedure)
Controls (Procedure)
Reset (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Execute (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Find (Procedure)
_PropertyGet (Procedure)
9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ErrorHandler(Optional ByVal pbCheck As Boolean) As Boolean
' Indicate if error handler is activated or not
' When argument present set error handler
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session
If Not IsMissing(pbCheck) Then _A2B_.ErrorHandler = pbCheck
_ErrorHandler = _A2B_.ErrorHandler
Exit Function
End Function
Access2BaseDev Trace _ErrorMessage Basic TraceError (Procedure) 29
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _ErrorMessage(ByVal piErrorNumber As Integer, Optional ByVal pvArgs As Variant) As String
' Return error message corresponding to ErrorNumber (standard or not)
' and replaces %0, %1, ... , %9 by psArgs(0), psArgs(1), ...

Dim sErrorMessage As String, i As Integer, sErrLabel
_ErrorMessage = ""
If piErrorNumber > ERRINIT Then
sErrLabel = "ERR" & piErrorNumber
sErrorMessage = _Getlabel(sErrLabel)
If Not IsMissing(pvArgs) Then
If Not IsArray(pvArgs) Then
sErrorMessage = Join(Split(sErrorMessage, "%0"), Utils._CStr(pvArgs, False))
Else
For i = LBound(pvArgs) To UBound(pvArgs)
sErrorMessage = Join(Split(sErrorMessage, "%" & i), Utils._CStr(pvArgs(i), False))
Next i
End If
End If
Else
sErrorMessage = Error(piErrorNumber)
' Most (or all?) error messages terminate with a "."
If Len(sErrorMessage) > 1 And Right(sErrorMessage, 1) = "." Then sErrorMessage = Left(sErrorMessage, Len(sErrorMessage)-1)
End If

_ErrorMessage = sErrorMessage
Exit Function

End Function ' ErrorMessage V0.8.9
Access2BaseDev Trace _PromptFilePicker Basic _DumpToFile (Procedure)
OutputTo (Procedure)
OutputTo (Procedure)
36
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _PromptFilePicker(ByVal psSuffix As String) As String
' Prompt for output file name
' Return "" if Cancel
' Modified from Andrew Pitonyak's Base Macro Programming §10.4

If _ErrorHandler() Then On Local Error GoTo Error_Function

Dim oFileDialog as Object, oUcb as object, oPath As Object
Dim iAccept as Integer, sInitPath as String

Set oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
oFileDialog.Initialize(Array(com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION))
Set oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")

oFileDialog.appendFilter("*." & psSuffix, "*." & psSuffix)
oFileDialog.appendFilter("*.*", "*.*")
oFileDialog.setCurrentFilter("*." & psSuffix)
Set oPath = createUnoService("com.sun.star.util.PathSettings")
sInitPath = oPath.Work ' Probably My Documents
If oUcb.Exists(sInitPath) Then oFileDialog.SetDisplayDirectory(sInitPath)

iAccept = oFileDialog.Execute()

_PromptFilePicker = ""
If iAccept = 1 Then ' Save button pressed
_PromptFilePicker = oFileDialog.Files(0)
End If

Exit_Function:
If Not IsEmpty(oFileDialog) And Not IsNull(oFileDialog) Then oFileDialog.Dispose()
Exit Function
Error_Function:
TraceError("ERROR", Err, "PromptFilePicker", Erl)
GoTo Exit_Function
End Function ' PromptFilePicker V0.8.5
Access2BaseDev Trace _TraceArguments Basic Controls (Procedure)
DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
AddItem (Procedure)
hasProperty (Procedure)
Move (Procedure)
Properties (Procedure)
Refresh (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
SetFocus (Procedure)
_OptionGroup (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
OpenForm (Procedure)
OpenQuery (Procedure)
OpenReport (Procedure)
OpenSQL (Procedure)
OpenTable (Procedure)
RunApp (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SetHiddenAttribute (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
getProperty (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
RunSQL (Procedure)
setAbsolutePosition (Procedure)
setAllowAdditions (Procedure)
setAllowDeletions (Procedure)
setAllowEdits (Procedure)
setBackColor (Procedure)
setBookmark (Procedure)
setBorderColor (Procedure)
setBorderStyle (Procedure)
setCancel (Procedure)
setCaption (Procedure)
setControlTipText (Procedure)
setCurrentRecord (Procedure)
setDefault (Procedure)
setDefaultValue (Procedure)
setDescription (Procedure)
setEnabled (Procedure)
setFilter (Procedure)
setFilterOn (Procedure)
setFontBold (Procedure)
setFontItalic (Procedure)
setFontName (Procedure)
setFontSize (Procedure)
setFontUnderline (Procedure)
setFontWeight (Procedure)
setForeColor (Procedure)
setHeight (Procedure)
setListIndex (Procedure)
setLocked (Procedure)
setMultiSelect (Procedure)
setOnAction (Procedure)
setOptionValue (Procedure)
setOrderBy (Procedure)
setOrderByOn (Procedure)
setPage (Procedure)
setProperty (Procedure)
setRecordSource (Procedure)
setRequired (Procedure)
setRowSource (Procedure)
setRowSourceType (Procedure)
setSelected (Procedure)
setSelLength (Procedure)
setSelStart (Procedure)
setSelText (Procedure)
setSpecialEffect (Procedure)
setTabIndex (Procedure)
setTabStop (Procedure)
setTag (Procedure)
setTextAlign (Procedure)
setTooltipText (Procedure)
setTripleState (Procedure)
setValue (Procedure)
setVisible (Procedure)
setWidth (Procedure)
Add (Procedure)
Delete (Procedure)
getProperty (Procedure)
Remove (Procedure)
getAbsolutePosition (Procedure)
getAllowAdditions (Procedure)
getAllowDeletions (Procedure)
getAllowEdits (Procedure)
getBackColor (Procedure)
getBeginGroup (Procedure)
getBOF (Procedure)
getBookmark (Procedure)
getBookmarkable (Procedure)
getBorderColor (Procedure)
getBorderStyle (Procedure)
getBuiltIn (Procedure)
getButtonLeft (Procedure)
getButtonMiddle (Procedure)
getButtonRight (Procedure)
getCancel (Procedure)
getCaption (Procedure)
getClickCount (Procedure)
getContextShortcut (Procedure)
getControlSource (Procedure)
getControlTipText (Procedure)
getControlType (Procedure)
getCount (Procedure)
getCurrentRecord (Procedure)
getDataType (Procedure)
getDbType (Procedure)
getDefault (Procedure)
getDefaultValue (Procedure)
getDescription (Procedure)
getEditMode (Procedure)
getEnabled (Procedure)
getEOF (Procedure)
getEventName (Procedure)
getEventType (Procedure)
getFieldSize (Procedure)
getFilter (Procedure)
getFilterOn (Procedure)
getFocusChangeTemporary (Procedure)
getFontBold (Procedure)
getFontItalic (Procedure)
getFontName (Procedure)
getFontSize (Procedure)
getFontUnderline (Procedure)
getFontWeight (Procedure)
getForm (Procedure)
getFormat (Procedure)
getHeight (Procedure)
getForeColor (Procedure)
getIsLoaded (Procedure)
getItemData (Procedure)
getKeyAlt (Procedure)
getKeyChar (Procedure)
getKeyCode (Procedure)
getKeyCtrl (Procedure)
getKeyFunction (Procedure)
getKeyShift (Procedure)
getLinkChildFields (Procedure)
getLinkMasterFields (Procedure)
getListCount (Procedure)
getListIndex (Procedure)
getLocked (Procedure)
getMultiSelect (Procedure)
getName (Procedure)
getObject (Procedure)
getObjectType (Procedure)
getOpenArgs (Procedure)
getOptionGroup (Procedure)
getOptionValue (Procedure)
getOrderBy (Procedure)
getOrderByOn (Procedure)
getPage (Procedure)
getParent (Procedure)
getProperty (Procedure)
getRecommendation (Procedure)
getRecordCount (Procedure)
getRecordset (Procedure)
getRecordSource (Procedure)
getRequired (Procedure)
getRowChangeAction (Procedure)
getRowSource (Procedure)
getRowSourceType (Procedure)
getSelected (Procedure)
getSize (Procedure)
getSource (Procedure)
getSourceField (Procedure)
getSourceTable (Procedure)
getSpecialEffect (Procedure)
getSubType (Procedure)
getSubComponentName (Procedure)
getSubComponentType (Procedure)
getTabIndex (Procedure)
getTabStop (Procedure)
getTag (Procedure)
getText (Procedure)
getTextAlign (Procedure)
getTooltipText (Procedure)
getTripleState (Procedure)
getTypeName (Procedure)
getValue (Procedure)
getVisible (Procedure)
getWidth (Procedure)
getXPos (Procedure)
getYPos (Procedure)
_hasProperty (Procedure)
OptionGroup (Procedure)
getProperty (Procedure)
Move (Procedure)
OptionGroup (Procedure)
getProperty (Procedure)
getProperty (Procedure)
getProperty (Procedure)
getProperty (Procedure)
AddItem (Procedure)
getProperty (Procedure)
RemoveItem (Procedure)
OptionGroup (Procedure)
getProperty (Procedure)
Move (Procedure)
AppendChunk (Procedure)
GetChunk (Procedure)
getProperty (Procedure)
CreateField (Procedure)
getProperty (Procedure)
getProperty (Procedure)
GetRows (Procedure)
Move (Procedure)
getProperty (Procedure)
getProperty (Procedure)
getProperty (Procedure)
Lines (Procedure)
ProcBodyLine (Procedure)
ProcCountLines (Procedure)
ProcOfLine (Procedure)
ProcStartLine (Procedure)
Find (Procedure)
getProperty (Procedure)
10
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _TraceArguments(Optional psCall As String)
' Process the ERRMISSINGARGUMENTS error
' psCall is present if error detected before call to _SetCalledSub

If Not IsMissing(psCall) Then Utils._SetCalledSub(psCall)
TraceError(TRACEFATAL, ERRMISSINGARGUMENTS, Utils._CalledSub(), 0)
Exit Sub

End Sub ' TraceArguments
Access2BaseDev Trace _TraceLevel Basic TraceConsole (Procedure)
TraceLevel (Procedure)
TraceLog (Procedure)
21
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _TraceLevel(ByVal pvTraceLevel As Variant) As Variant
' Convert string trace level to numeric value or the opposite

Dim vTraces As Variant, i As Integer
vTraces = Array(TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT, TRACEANY)

Select Case VarType(pvTraceLevel)
Case vbString
_TraceLevel = 4 ' 4 = Default
For i = 0 To UBound(vTraces)
If UCase(pvTraceLevel) = UCase(vTraces(i)) Then
_TraceLevel = i + 1
Exit For
End If
Next i
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
If pvTraceLevel < 1 Or pvTraceLevel > UBound(vTraces) + 1 Then _TraceLevel = TRACEERRORS Else _TraceLevel = vTraces(pvTraceLevel - 1)
End Select

End Function ' TraceLevel
Access2BaseDev Trace TraceConsole Basic   111
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceConsole()
' Display the Trace dialog with current trace log values and parameter choices
If _ErrorHandler() Then On Local Error Goto Error_Sub

Dim sLineBreak As String, oTraceDialog As Object
sLineBreak = vbNewLine

Set oTraceDialog = CreateUnoDialog(Utils._GetDialogLib().dlgTrace)
oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE") ' HelpText ???

Dim oEntries As Object, oTraceLog As Object, oClear As Object, oMinLevel As Object, oNbEntries As Object, oDump As Object
Dim oControl As Object
Dim i As Integer, sText As String, iOKCancel As Integer

Set oNbEntries = oTraceDialog.Model.getByName("numNbEntries")
oNbEntries.Value = _A2B_.TraceLogCount
oNbEntries.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP")

Set oControl = oTraceDialog.Model.getByName("lblNbEntries")
oControl.Label = _GetLabel("DLGTRACE_LBLNBENTRIES_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP")

Set oEntries = oTraceDialog.Model.getByName("numEntries")
If _A2B_.TraceLogMaxEntries = 0 Then _A2B_.TraceLogMaxEntries = cstLogMaxEntries
oEntries.Value = _A2B_.TraceLogMaxEntries
oEntries.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP")

Set oControl = oTraceDialog.Model.getByName("lblEntries")
oControl.Label = _GetLabel("DLGTRACE_LBLENTRIES_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP")

Set oDump = oTraceDialog.Model.getByName("cmdDump")
oDump.Enabled = 0
oDump.Label = _GetLabel("DLGTRACE_CMDDUMP_LABEL")
oDump.HelpText = _GetLabel("DLGTRACE_CMDDUMP_HELP")

Set oTraceLog = oTraceDialog.Model.getByName("txtTraceLog")
oTraceLog.HelpText = _GetLabel("DLGTRACE_TXTTRACELOG_HELP")
If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized
oTraceLog.HardLineBreaks = True
sText = ""
If _A2B_.TraceLogCount > 0 Then
If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast
Do
If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0
If Len(_A2B_.TraceLogs(i)) > 11 Then
sText = sText & Right(_A2B_.TraceLogs(i), Len(_A2B_.TraceLogs(i)) - 11) & sLineBreak ' Skip date in display
End If
Loop While i <> _A2B_.TraceLogLast
oDump.Enabled = 1 ' Enable DumpToFile only if there is something to dump
End If
If Len(sText) > 0 Then sText = Left(sText, Len(sText) - Len(sLineBreak)) ' Skip last linefeed
oTraceLog.Text = sText
Else
oTraceLog.Text = _GetLabel("DLGTRACE_TXTTRACELOG_TEXT")
End If

Set oClear = oTraceDialog.Model.getByName("chkClear")
oClear.State = 0 ' Unchecked
oClear.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP")

Set oControl = oTraceDialog.Model.getByName("lblClear")
oControl.Label = _GetLabel("DLGTRACE_LBLCLEAR_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP")

Set oMinLevel = oTraceDialog.Model.getByName("cboMinLevel")
If _A2B_.MinimalTraceLevel = 0 Then _A2B_.MinimalTraceLevel = _TraceLevel(TRACEERRORS)
oMinLevel.Text = _TraceLevel(_A2B_.MinimalTraceLevel)
oMinLevel.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP")

Set oControl = oTraceDialog.Model.getByName("lblMinLevel")
oControl.Label = _GetLabel("DLGTRACE_LBLMINLEVEL_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP")

Set oControl = oTraceDialog.Model.getByName("cmdOK")
oControl.Label = _GetLabel("DLGTRACE_CMDOK_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_CMDOK_HELP")

Set oControl = oTraceDialog.Model.getByName("cmdCancel")
oControl.Label = _GetLabel("DLGTRACE_CMDCANCEL_LABEL")
oControl.HelpText = _GetLabel("DLGTRACE_CMDCANCEL_HELP")

iOKCancel = oTraceDialog.Execute()

Select Case iOKCancel
Case 1 ' OK
If oClear.State = 1 Then
_A2B_.TraceLogs() = Array() ' Erase logged traces
_A2B_.TraceLogCount = 0
End If
If oMinLevel.Text <> "" Then _A2B_.MinimalTraceLevel = _TraceLevel(oMinLevel.Text)
If oEntries.Value <> 0 And oEntries.Value <> _A2B_.TraceLogMaxEntries Then
_A2B_.TraceLogs() = Array()
_A2B_.TraceLogMaxEntries = oEntries.Value
End If
Case 0 ' Cancel
Case Else
End Select

Exit_Sub:
If Not IsNull(oTraceDialog) Then oTraceDialog.Dispose()
Exit Sub
Error_Sub:
With _A2B_
.TraceLogs() = Array()
.TraceLogCount = 0
.TraceLogLast = 0
End With
GoTo Exit_Sub
End Sub ' TraceConsole V1.1.0
Access2BaseDev Trace TraceError Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CommandBars (Procedure)
Controls (Procedure)
Events (Procedure)
Forms (Procedure)
HtmlEncode (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
_CurrentDb (Procedure)
AddItem (Procedure)
Move (Procedure)
Refresh (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
SetFocus (Procedure)
_OptionGroup (Procedure)
_DumpToFile (Procedure)
_PromptFilePicker (Procedure)
_TraceArguments (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindNext (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OpenQuery (Procedure)
OpenReport (Procedure)
OpenSQL (Procedure)
OpenTable (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunApp (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
_ConvertDataDescriptor (Procedure)
_DatabaseForm (Procedure)
_OpenObject (Procedure)
_SelectWindow (Procedure)
_SendWithAttachment (Procedure)
_SendWithoutAttachment (Procedure)
_CheckArgument (Procedure)
_getTempDirectoryURL (Procedure)
mClose (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_DFunction (Procedure)
_OutputDataToHTML (Procedure)
_OutputToCalc (Procedure)
_PropertyGet (Procedure)
_setProperty (Procedure)
Item (Procedure)
Add (Procedure)
Delete (Procedure)
Remove (Procedure)
RemoveAll (Procedure)
_PropertyGet (Procedure)
getObject (Procedure)
getOptionGroup (Procedure)
_getProperty (Procedure)
_Properties (Procedure)
IsLoaded (Procedure)
OptionGroup (Procedure)
mClose (Procedure)
Controls (Procedure)
Move (Procedure)
Refresh (Procedure)
Requery (Procedure)
setFocus (Procedure)
_Initialize (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Parent (Procedure)
Controls (Procedure)
Refresh (Procedure)
Requery (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_Initialize (Procedure)
_PropertyGet (Procedure)
_PropertyGet (Procedure)
AddItem (Procedure)
Controls (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
setFocus (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Execute (Procedure)
Move (Procedure)
Start (Procedure)
Terminate (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AppendChunk (Procedure)
GetChunk (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_ReadAll (Procedure)
_WriteAll (Procedure)
CreateField (Procedure)
Execute (Procedure)
Fields (Procedure)
OpenRecordset (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AddNew (Procedure)
CancelUpdate (Procedure)
Clone (Procedure)
Delete (Procedure)
Edit (Procedure)
Fields (Procedure)
GetRows (Procedure)
OpenRecordset (Procedure)
Update (Procedure)
_AppendChunk (Procedure)
_AppendChunkClose (Procedure)
_Initialize (Procedure)
_Move (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CloseConnection (Procedure)
CurrentDocIndex (Procedure)
_CurrentDb (Procedure)
CommandBarControls (Procedure)
Controls (Procedure)
Reset (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Execute (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Find (Procedure)
_FindProcIndex (Procedure)
_PropertyGet (Procedure)
33
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceError(ByVal psErrorLevel As String _
, ByVal piErrorCode As Integer _
, ByVal psErrorProc As String _
, ByVal piErrorLine As Integer _
, ByVal Optional pvMsgBox As Variant _
, ByVal Optional pvArgs As Variant _
)
' store error codes in trace buffer

On Local Error Resume Next
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session

Dim sErrorText As String, sErrorDesc As String, oDb As Object
sErrorDesc = _ErrorMessage(piErrorCode, pvArgs)
sErrorText = _GetLabel("ERR#") & CStr(piErrorCode) _
& " (" & sErrorDesc & ") " & _GetLabel("ERROCCUR") _
& Iif(piErrorLine > 0, " " & _GetLabel("ERRLINE") & " " & CStr(piErrorLine), "") _
& Iif(psErrorProc <> "", " " & _GetLabel("ERRIN") & " " & psErrorProc, Iif(_A2B_.CalledSub = "", "", " " & _Getlabel("ERRIN") & " " & _A2B_.CalledSub))
If IsMissing(pvMsgBox) Then pvMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT )
TraceLog(psErrorLevel, sErrorText, pvMsgBox)

' Unexpected error detected in user program or in Access2Base
If psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT Then
_A2B_.CalledSub = ""
If psErrorLevel = TRACEFATAL Then
Set oDb = Application.CurrentDb()
If Not IsNull(oDb) Then oDb.CloseAllrecordsets()
End If
Stop
End If

End Sub ' TraceError V0.9,5
Access2BaseDev Trace TraceLevel Basic   25
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceLevel(ByVal Optional psTraceLevel As String)
' Set trace level to argument

If _ErrorHandler() Then On Local Error Goto Error_Sub
Select Case True
Case IsMissing(psTraceLevel) : psTraceLevel = "ERROR"
Case psTraceLevel = "" : psTraceLevel = "ERROR"
Case Utils._InList(UCase(psTraceLevel), Array( _
TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT _
))
Case Else : Goto Exit_Sub
End Select
_A2B_.MinimalTraceLevel = _TraceLevel(psTraceLevel)

Exit_Sub:
Exit Sub
Error_Sub:
With _A2B_
.TraceLogs() = Array()
.TraceLogCount = 0
.TraceLogLast = 0
End With
GoTo Exit_Sub
End Sub ' TraceLevel V0.9.5
Access2BaseDev Trace TraceLog Basic OpenConnection (Procedure)
OpenDatabase (Procedure)
TraceError (Procedure)
OpenForm (Procedure)
_ResetCalledSub (Procedure)
_SetCalledSub (Procedure)
DebugPrint (Procedure)
CloseConnection (Procedure)
53
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub TraceLog(Byval psTraceLevel As String _
, ByVal psText As String _
, ByVal Optional pbMsgBox As Boolean _
)
' Store Text in trace log (circular buffer)

If _ErrorHandler() Then On Local Error Goto Error_Sub
Dim vTraceLogs() As String, sTraceLevel As String

With _A2B_
If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS)
If _TraceLevel(psTraceLevel) < .MinimalTraceLevel Then Exit Sub

If UBound(.TraceLogs) = -1 Then ' Initialize TraceLog
If .TraceLogMaxEntries = 0 Then .TraceLogMaxEntries = cstLogMaxEntries

Redim vTraceLogs(0 To .TraceLogMaxEntries - 1)
.TraceLogs = vTraceLogs
.TraceLogCount = 0
.TraceLogLast = -1
If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) ' Set default value
End If

.TraceLogLast = .TraceLogLast + 1
If .TraceLogLast > UBound(.TraceLogs) Then .TraceLogLast = LBound(.TraceLogs) ' Circular buffer
If Len(psTraceLevel) > 7 Then sTraceLevel = Left(psTraceLevel, 7) Else sTraceLevel = psTraceLevel & Spc(8 - Len(psTraceLevel))
.TraceLogs(.TraceLogLast) = Format(Now(), "YYYY-MM-DD hh:mm:ss") & " " & sTraceLevel & psText
If .TraceLogCount <= UBound(.TraceLogs) Then .TraceLogCount = .TraceLogCount + 1 ' # of active entries
End With

If IsMissing(pbMsgBox) Then pbMsgBox = True
Dim iMsgBox As Integer
If pbMsgBox Then
Select Case psTraceLevel
Case TRACEINFO: iMsgBox = vbInformation
Case TRACEERRORS, TRACEWARNING: iMsgBox = vbExclamation
Case TRACEFATAL, TRACEABORT: iMsgBox = vbCritical
Case Else: iMsgBox = vbInformation
End Select
MsgBox psText, vbOKOnly + iMsgBox, psTraceLevel
End If

Exit_Sub:
Exit Sub
Error_Sub:
With _A2B_
.TraceLogs() = Array()
.TraceLogCount = 0
.TraceLogLast = 0
End With
GoTo Exit_Sub
End Sub ' TraceLog V0.9.5
Access2BaseDev UtilProperty _CheckPropertyValue Basic _MakePropertyValue (Procedure)
_SetPropertyValue (Procedure)
14
REM =======================================================================================================================
Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant
' Date BASIC variables give error. Change them to strings
' Empty arrays should be replaced by cstEMPTYARRAY

If VarType(pvValue) = vbDate Then
_CheckPropertyValue = Utils._CStr(pvValue, False)
ElseIf IsArray(pvValue) Then
If UBound(pvValue, 1) < LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue
Else
_CheckPropertyValue = pvValue
End If

End Function ' _CheckPropertyValue
Access2BaseDev UtilProperty _DeleteIndexedProperty Basic _DeleteProperty (Procedure) 26
REM =======================================================================================================================
Public Sub _DeleteIndexedProperty(ByRef pvPropertyValuesArray As Variant, ByVal piPropIndex As Integer)
' Delete a particular indexed property from an array of PropertyValue's.

Dim iNumProperties As Integer, i As Integer
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)

' Did we find it?
If piPropIndex < 0 Then
' Do nothing
ElseIf iNumProperties = 1 Then
' Just return a new empty array
pvPropertyValuesArray = Array()
Else
' If it is NOT the last item in the array, then shift other elements down into it's position.
If piPropIndex < iNumProperties - 1 Then
' Bump items down lower in the array.
For i = piPropIndex To iNumProperties - 2
pvPropertyValuesArray(i) = pvPropertyValuesArray(i + 1)
Next i
EndIf
' Redimension the array to have one fewer element.
Redim Preserve pvPropertyValuesArray(iNumProperties - 2)
EndIf

End Sub ' _DeleteIndexedProperty V1.3.0
Access2BaseDev UtilProperty _DeleteProperty Basic   9
REM =======================================================================================================================
Public Sub _DeleteProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String)
' Delete a particular named property from an array of PropertyValue's.

Dim iPropIndex As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex)

End Sub ' _DeletePropertyValue V1.3.0
Access2BaseDev UtilProperty _FindProperty Basic   13
REM =======================================================================================================================
Public Function _FindProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) As com.sun.star.beans.PropertyValue
' Find a particular named property from an array of PropertyValue's.
' Finds the PropertyValue and returns it, or returns Null if not found.

Dim iPropIndex As Integer, vProp As Variant
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
_FindProperty() = vProp
EndIf

End Function ' _FindProperty V1.3.0
Access2BaseDev UtilProperty _FindPropertyIndex Basic _FindProperty (Procedure)
_GetPropertyValue (Procedure)
_SetPropertyValue (Procedure)
_DeleteProperty (Procedure)
17
REM =======================================================================================================================
Public Function _FindPropertyIndex(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String ) As Integer
' Find a particular named property from an array of PropertyValue's.
' Finds the index in the array of PropertyValue's and returns it, or returns -1 if it was not found.

Dim iNumProperties As Integer, i As Integer, vProp As Variant
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
For i = 0 To iNumProperties - 1
vProp = pvPropertyValuesArray(i)
If UCase(vProp.Name) = UCase(psPropName) Then
_FindPropertyIndex() = i
Exit Function
EndIf
Next i
_FindPropertyIndex() = -1

End Function ' _FindPropertyIndex V1.3.0
Access2BaseDev UtilProperty _GetPropertyValue Basic CommandBars (Procedure)
CommandBarControls (Procedure)
Execute (Procedure)
_PropertyGet (Procedure)
34
REM =======================================================================================================================
Public Function _GetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, Optional pvDefaultValue) As Variant
' Get the value of a particular named property from an array of PropertyValue's.
' vDefaultValue - This value is returned if the property is not found in the array.

Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Variant, i As Integer, j As Integer
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
vValue = vProp.Value ' get the value from the PropertyValue
If VarType(vValue) = vbString Then
If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue
ElseIf IsArray(vValue) Then
If IsArray(vValue(0)) Then ' Array of arrays
vMatrix = Array()
ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0)))
For i = 0 To UBound(vValue)
For j = 0 To UBound(vValue(0))
vMatrix(i, j) = vValue(i)(j)
Next j
Next i
_GetPropertyValue() = vMatrix
Else
_GetPropertyValue() = vValue ' Simple vector OK
End If
Else
_GetPropertyValue() = vValue
End If
Else
If IsMissing(pvDefaultValue) Then pvDefaultValue = Null
_GetPropertyValue() = pvDefaultValue
EndIf

End Function ' _GetPropertyValue V1.3.0
Access2BaseDev UtilProperty _MakePropertyValue Basic OutputTo (Procedure)
_OutputToCalc (Procedure)
_SetPropertyValue (Procedure)
11
REM =======================================================================================================================
Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue
' Create and return a new com.sun.star.beans.PropertyValue.

Dim oPropertyValue As New com.sun.star.beans.PropertyValue

If Not IsMissing(psName) Then oPropertyValue.Name = psName
If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue)
_MakePropertyValue() = oPropertyValue

End Function ' _MakePropertyValue V1.3.0
Access2BaseDev UtilProperty _NumPropertyValues Basic _FindPropertyIndex (Procedure)
_SetPropertyValue (Procedure)
_DeleteIndexedProperty (Procedure)
_PropValuesToStr (Procedure)
12
REM =======================================================================================================================
Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer
' Return the number of PropertyValue's in an array.
' Parameters:
' pvPropertyValuesArray - an array of PropertyValue's, that is an array of com.sun.star.beans.PropertyValue.
' Returns zero if the array contains no elements.

Dim iNumProperties As Integer
If Not IsArray(pvPropertyValuesArray) Then iNumProperties = 0 Else iNumProperties = UBound(pvPropertyValuesArray) + 1
_NumPropertyValues() = iNumProperties

End Function ' _NumPropertyValues V1.3.0
Access2BaseDev UtilProperty _PropValuesToStr Basic   47
REM =======================================================================================================================
Public Function _PropValuesToStr(ByRef pvPropertyValuesArray As Variant) As String
' Return a string with dumped content of the array of PropertyValue's.
' SYNTAX:
' NameOfProperty = This is a string (or 12 or 2016-12-31 12:05 or 123.45 or -0.12E-05 ...)
' NameOfArray = (10)
' 1;2;3;4;5;6;7;8;9;10
' NameOfMatrix = (2,10)
' 1;2;3;4;5;6;7;8;9;10
' A;B;C;D;E;F;G;H;I;J
' Semicolons and backslashes are escaped with a backslash (see _CStr and _CVar functions)

Dim iNumProperties As Integer, sResult As String, i As Integer, j As Integer, vProp As Variant
Dim sName As String, vValue As Variant, iType As Integer
Dim cstLF As String

cstLF = vbLf()
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)

sResult = cstHEADER & cstLF
For i = 0 To iNumProperties - 1
vProp = pvPropertyValuesArray(i)
sName = vProp.Name
vValue = vProp.Value
iType = VarType(vValue)
Select Case iType
Case < vbArray ' Scalar
sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF
Case Else ' Vector or matrix
If uBound(vValue, 1) < 0 Then
sResult = sResult & sName & " = (0)" & cstLF
' 1-dimension but vector of vectors must also be considered
ElseIf VarType(vValue(0)) >= vbArray Then
sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF
For j = 0 To UBound(vValue)
sResult = sResult & Utils._CStr(vValue(j), False) & cstLF
Next j
Else
sResult = sResult & sName & " = (" & UBound(vValue, 1) + 1 & ")" & cstLF
sResult = sResult & Utils._CStr(vValue, False) & cstLF
End If
End Select
Next i

_PropValuesToStr() = Left(sResult, Len(sResult) - 1) ' Remove last LF

End Function ' _PropValuesToStr V1.3.0
Access2BaseDev UtilProperty _SetPropertyValue Basic _StrToPropValues (Procedure)
_PropertySet (Procedure)
26
REM =======================================================================================================================
Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue As Variant)
' Set the value of a particular named property from an array of PropertyValue's.

Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer

iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
If iPropIndex >= 0 Then
' Found, the PropertyValue is already in the array. Just modify its value.
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
vProp.Value = _CheckPropertyValue(pvValue) ' set the property value.
pvPropertyValuesArray(iPropIndex) = vProp ' put it back into array
Else
' Not found, the array contains no PropertyValue with this name. Append new element to array.
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
If iNumProperties = 0 Then
pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue))
Else
' Make array larger.
Redim Preserve pvPropertyValuesArray(iNumProperties)
' Assign new PropertyValue
pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue)
EndIf
EndIf

End Sub ' _SetPropertyValue V1.3.0
Access2BaseDev UtilProperty _StrToPropValues Basic   74
REM =======================================================================================================================
Public Function _StrToPropValues(psString) As Variant
' Return an array of PropertyValue's rebuilt from the string parameter

Dim vString() As Variant, i As Integer,iArray As Integer, iRows As Integer, iCols As Integer
Dim lPosition As Long, sName As String, vValue As Variant, vResult As Variant, sDim As String
Dim lSearch As Long
Dim cstLF As String
Const cstEqualArray = " = (", cstEqual = " = "

cstLF = Chr(10)
_StrToPropValues = Array()
vResult = Array()

If psString = "" Then Exit Function
vString = Split(psString, cstLF)
If UBound(vString) <= 0 Then Exit Function ' There must be at least one name-value pair
If vString(0) <> cstHEADER Then Exit Function ' Check origin

iArray = -1
For i = 1 To UBound(vString)
If vString(i) <> "" Then ' Skip empty lines
If iArray < 0 Then ' Not busy with array row
lPosition = 1
sName = Utils._RegexSearch(vString(i), "^\b\w+\b", lPosition) ' Identifier
If sName = "" Then Exit Function
If InStr(vString(i), cstEqualArray) = lPosition + Len(sName) Then ' Start array processing
lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
sDim = Utils._RegexSearch(vString(i), "\([0-9]+\)", lSearch) ' e.g. (10)
If sDim = "(0)" Then ' Empty array
iRows = -1
vValue = Array()
_SetPropertyValue(vResult, sName, vValue)
ElseIf sDim <> "" Then ' Vector with content
iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
iRows = 0
ReDim vValue(0 To iCols - 1)
iArray = 0
Else ' Matrix with content
lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
sDim = Utils._RegexSearch(vString(i), "\([0-9]+,", lSearch) ' e.g. (10,
iRows = CInt(Mid(sDim, 2, Len(sDim) - 2))
sDim = Utils._RegexSearch(vString(i), ",[0-9]+\)", lSearch) ' e.g. ,20)
iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
ReDim vValue(0 To iRows - 1)
iArray = 0
End If
ElseIf InStr(vString(i), cstEqual) = lPosition + Len(sName) Then
vValue = Utils._CVar(Mid(vString(i), Len(sName) + Len(cstEqual) + 1))
_SetPropertyValue(vResult, sName, vValue)
Else
Exit Function
End If
Else ' Line is an array row
If iRows = 0 Then
vValue = Utils._CVar(vString(i), True) ' Keep dates as strings
iArray = -1
_SetPropertyValue(vResult, sName, vValue)
Else
vValue(iArray) = Utils._CVar(vString(i), True)
If iArray < iRows - 1 Then
iArray = iArray + 1
Else
iArray = -1
_SetPropertyValue(vResult, sName, vValue)
End If
End If
End If
End If
Next i

_StrToPropValues = vResult

End Function
Access2BaseDev Utils _AddArray Basic _OutputDataToHTML (Procedure) 10
Public Function _AddArray(ByVal pvArray As Variant, pvItem As Variant) As Variant
'Add the item at the end of the array

Dim vArray() As Variant
If IsArray(pvArray) Then vArray = pvArray Else vArray = Array()
ReDim Preserve vArray(LBound(vArray) To UBound(vArray) + 1)
vArray(UBound(vArray)) = pvItem
_AddArray() = vArray()

End Function
Access2BaseDev Utils _AddNumeric Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CommandBars (Procedure)
Controls (Procedure)
Forms (Procedure)
HtmlEncode (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToRecord (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
_CheckColumnType (Procedure)
_OpenObject (Procedure)
CreateQueryDef (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_setProperty (Procedure)
Item (Procedure)
_getProperty (Procedure)
_Properties (Procedure)
Controls (Procedure)
Move (Procedure)
_PropertySet (Procedure)
DebugPrint (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertySet (Procedure)
AddItem (Procedure)
Controls (Procedure)
RemoveItem (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Move (Procedure)
_PropertySet (Procedure)
GetChunk (Procedure)
_PropertySet (Procedure)
CreateField (Procedure)
Execute (Procedure)
Fields (Procedure)
OpenRecordset (Procedure)
Fields (Procedure)
GetRows (Procedure)
Move (Procedure)
OpenRecordset (Procedure)
_PropertySet (Procedure)
CommandBarControls (Procedure)
_PropertySet (Procedure)
Lines (Procedure)
ProcBodyLine (Procedure)
ProcCountLines (Procedure)
ProcOfLine (Procedure)
ProcStartLine (Procedure)
Find (Procedure)
25
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _AddNumeric(ByVal Optional pvTypes As Variant) As Variant
'Return on top of argument the list of all numeric types
'Facilitates the entry of the list of allowed types in _CheckArgument calls

Dim i As Integer, vNewList() As Variant, vNumeric() As Variant, iSize As Integer
If IsMissing(pvTypes) Then
vNewList = Array()
ElseIf IsArray(pvTypes) Then
vNewList = pvTypes
Else
vNewList = Array(pvTypes)
End If

vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal, vbBoolean)

iSize = UBound(vNewlist)
ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1)
For i = 0 To UBound(vNumeric)
vNewList(iSize + i + 1) = vNumeric(i)
Next i

_AddNumeric = vNewList

End Function ' _AddNumeric V0.8.0
Access2BaseDev Utils _BitShift Basic _Initialize (Procedure) 28
Public Function _BitShift(piValue As Integer, piConstant As Integer) As Boolean

_BitShift = False
If piValue = 0 Then Exit Function
Select Case piConstant
Case 1
Select Case piValue
Case 1, 3, 5, 7, 9, 11, 13, 15: _BitShift = True
Case Else
End Select
Case 2
Select Case piValue
Case 2, 3, 6, 7, 10, 11, 14, 15: _BitShift = True
Case Else
End Select
Case 4
Select Case piValue
Case 4, 5, 6, 7, 12, 13, 14, 15: _BitShift = True
Case Else
End Select
Case 8
Select Case piValue
Case 8, 9, 10, 11, 12, 13, 14, 15: _BitShift = True
Case Else
End Select
End Select

End Function ' BitShift
Access2BaseDev Utils _CalledSub Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CommandBars (Procedure)
Events (Procedure)
Forms (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
_CurrentDb (Procedure)
SetFocus (Procedure)
_OptionGroup (Procedure)
_TraceArguments (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindNext (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToRecord (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunCommand (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
_ConvertDataDescriptor (Procedure)
_DatabaseForm (Procedure)
_OpenObject (Procedure)
_SendWithAttachment (Procedure)
_CheckArgument (Procedure)
mClose (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_PropertyGet (Procedure)
_setProperty (Procedure)
Item (Procedure)
Add (Procedure)
Delete (Procedure)
Remove (Procedure)
RemoveAll (Procedure)
_PropertyGet (Procedure)
getObject (Procedure)
_getProperty (Procedure)
_Properties (Procedure)
mClose (Procedure)
Controls (Procedure)
Move (Procedure)
_Initialize (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertyGet (Procedure)
AddItem (Procedure)
Controls (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
setFocus (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Execute (Procedure)
Move (Procedure)
Start (Procedure)
Terminate (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AppendChunk (Procedure)
GetChunk (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_ReadAll (Procedure)
_WriteAll (Procedure)
CreateField (Procedure)
Execute (Procedure)
Fields (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AddNew (Procedure)
Clone (Procedure)
Delete (Procedure)
Edit (Procedure)
Fields (Procedure)
GetRows (Procedure)
OpenRecordset (Procedure)
Update (Procedure)
_Initialize (Procedure)
_Move (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CurrentDocIndex (Procedure)
_CurrentDb (Procedure)
CommandBarControls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_FindProcIndex (Procedure)
_PropertyGet (Procedure)
4
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CalledSub() As String
_CalledSub = Iif(_A2B_.CalledSub = "", "", _GetLabel("CALLTO") & " '" & _A2B_.CalledSub & "'")
End Function ' CalledSub V0.8.9
Access2BaseDev Utils _CheckArgument Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CommandBars (Procedure)
Controls (Procedure)
Events (Procedure)
Forms (Procedure)
HtmlEncode (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
AddItem (Procedure)
hasProperty (Procedure)
Move (Procedure)
Properties (Procedure)
Refresh (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
SetFocus (Procedure)
_OptionGroup (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunApp (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
_OpenObject (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_setProperty (Procedure)
Item (Procedure)
Add (Procedure)
Delete (Procedure)
Remove (Procedure)
getObject (Procedure)
getOptionGroup (Procedure)
_getProperty (Procedure)
_hasProperty (Procedure)
_Properties (Procedure)
Controls (Procedure)
Move (Procedure)
_PropertySet (Procedure)
DebugPrint (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertySet (Procedure)
AddItem (Procedure)
Controls (Procedure)
RemoveItem (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Move (Procedure)
_PropertySet (Procedure)
GetChunk (Procedure)
ReadAllBytes (Procedure)
ReadAllText (Procedure)
WriteAllBytes (Procedure)
WriteAllText (Procedure)
_PropertySet (Procedure)
CreateField (Procedure)
Execute (Procedure)
Fields (Procedure)
OpenRecordset (Procedure)
_PropertySet (Procedure)
Fields (Procedure)
GetRows (Procedure)
Move (Procedure)
OpenRecordset (Procedure)
_PropertySet (Procedure)
CommandBarControls (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
Lines (Procedure)
ProcBodyLine (Procedure)
ProcCountLines (Procedure)
ProcOfLine (Procedure)
ProcStartLine (Procedure)
Find (Procedure)
36
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CheckArgument(pvItem As Variant _
, ByVal piArgNr As Integer _
, Byval pvType As Variant _
, ByVal Optional pvValid As Variant _
, ByVal Optional pvError As Boolean _
) As Variant
' Called by public functions to check the validity of their arguments
' pvItem Argument to be checked
' piArgNr Argument sequence number
' pvType Single value or array of allowed variable types
' If of string type must contain one or more valid pseudo-object types
' pvValid Single value or array of allowed values - comparison for strings is case-insensitive
' pvError If True (default), error handling in this routine. False in _setProperty methods in class modules.

_CheckArgument = False

Dim iVarType As Integer
If IsArray(pvType) Then iVarType = VarType(pvType(LBound(pvType))) Else iVarType = VarType(pvType)
If iVarType = vbString Then ' pvType is a pseudo-type string
_CheckArgument = Utils._IsPseudo(pvItem, pvType)
Else
If IsMissing(pvValid) Then _CheckArgument = Utils._IsScalar(pvItem, pvType) Else _CheckArgument = Utils._IsScalar(pvItem, pvType, pvValid)
End If

If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem)

Exit_Function:
If Not _CheckArgument Then
If IsMissing(pvError) Then pvError = True
If pvError Then
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(piArgNr, pvItem))
End If
End If
Exit Function
End Function ' CheckArgument V0.9.0
Access2BaseDev Utils _CStr Basic Events (Procedure)
_ErrorMessage (Procedure)
_OutputDataToHTML (Procedure)
DebugPrint (Procedure)
EndExecute (Procedure)
GetRows (Procedure)
_CheckPropertyValue (Procedure)
_PropValuesToStr (Procedure)
80
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
' Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
' pvArg may be a byte-array. Other arrays are processed recursively into a semicolon separated string

Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long
Const cstLength = 50
Const cstByteLength = 25

If IsMissing(pbShort) Then pbShort = True
If IsArray(pvArg) Then
sArg = ""
If VarType(pvArg) = vbByte Or VarType(pvArg) = vbArray + vbByte Then
If pbShort And UBound(pvArg) > cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg)
For i = 0 To iMax
sArg = sArg & Right("00" & Hex(pvArg(i)), 2)
Next i
Else
If pbShort Then
sArg = "[ARRAY]"
Else ' One-dimension arrays only
For i = LBound(pvArg) To UBound(pvArg)
sArg = sArg & Utils._CStr(pvArg(i), pbShort) & ";" ' Recursive call
Next i
If Len(sArg) > 1 Then sArg = Left(sArg, Len(sArg) - 1)
End If
End If
Else
Select Case VarType(pvArg)
Case vbEmpty : sArg = "[EMPTY]"
Case vbNull : sArg = "[NULL]"
Case vbObject
If IsNull(pvArg) Then
sArg = "[NULL]"
Else
sObject = Utils._ImplementationName(pvArg)
If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _
, OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _
, OBJDIALOG _
)) Then
Set oArg = pvArg ' To avoid "Object variable not set" error message
sArg = "[" & oArg._Type & "] " & oArg._Name
ElseIf sObject <> "" Then
sArg = "[" & sObject & "]"
Else
sArg = "[OBJECT]"
End If
End If
Case vbVariant : sArg = "[VARIANT]"
Case vbString
' Replace CR + LF by \n and HT by \t
' Replace semicolon by \; to allow semicolon separated rows
sArg = Replace( _
Replace( _
Replace( _
Replace( _
Replace(pvArg, "\", "\\") _
, Chr(13), "") _
, Chr(10), "\n") _
, Chr(9), "\t") _
, ";", "\;")
Case vbBoolean : sArg = Iif(pvArg, "[TRUE]", "[FALSE]")
Case vbByte : sArg = Right("00" & Hex(pvArg), 2)
Case vbSingle, vbDouble, vbCurrency
sArg = Format(pvArg)
If InStr(UCase(sArg), "E") = 0 Then sArg = Format(pvArg, "##0.0##")
sArg = Replace(sArg, ",", ".")
Case vbBigint : sArg = CStr(CLng(pvArg))
Case vbDate : sArg = Year(pvArg) & "-" & Right("0" & Month(pvArg), 2) & "-" & Right("0" & Day(pvArg), 2) _
& " " & Right("0" & Hour(pvArg), 2) & ":" & Right("0" & Minute(pvArg), 2)
Case Else : sArg = CStr(pvArg)
End Select
End If
If pbShort And Len(sArg) > cstLength Then
sLength = "(" & Len(sArg) & ")"
sArg = Left(sArg, cstLength - 5 - Len(slength)) & " ... " & sLength
End If
_CStr = sArg

End Function ' CStr V0.9.5
Access2BaseDev Utils _CVar Basic _StrToPropValues (Procedure) 57
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _CVar(ByRef psArg As String, ByVal Optional pbStrDate As Boolean) As Variant
' psArg is presumed an output of _CStr (stored in the mean time in a text file f.i.)
' _CVar returns the corresponding original variant variable or Null/Nothing if not possible
' Return values may of types Array, Long, Double, Date, Boolean, String, Null or Empty
' pbStrDate = True keeps dates as strings

Dim cstEscape1 As String, cstEscape2 As String
cstEscape1 = Chr(14) ' Form feed used as temporary escape character for \\
cstEscape2 = Chr(27) ' ESC used as temporary escape character for \;

_CVar = ""
If Len(psArg) = 0 Then Exit Function

Dim sArg As String, vArgs() As Variant, vVars() As Variant, i As Integer
If IsMissing(pbStrDate) Then pbStrDate = False
sArg = Replace( _
Replace( _
Replace( _
Replace(psArg, "\\", cstEscape1) _
, "\;", cstEscape2) _
, "\n", Chr(10)) _
, "\t", Chr(9))

' Semicolon separated string
vArgs = Split(sArg, ";")
If UBound(vArgs) > LBound(vArgs) Then ' Process each item recursively
vVars = Array()
Redim vVars(LBound(vArgs) To UBound(vArgs))
For i = LBound(vVars) To UBound(vVars)
vVars(i) = _CVar(vArgs(i), pbStrDate)
Next i
_CVar = vVars
Exit Function
End If

' Usual case
Select Case True
Case sArg = "[EMPTY]" : _CVar = EMPTY
Case sArg = "[NULL]" Or sArg = "[VARIANT]" : _CVar = Null
Case sArg = "[OBJECT]" : _CVar = Nothing
Case sArg = "[TRUE]" : _CVar = True
Case sArg = "[FALSE]" : _CVar = False
Case IsDate(sArg)
If pbStrDate Then _CVar = sArg Else _CVar = CDate(sArg)
Case IsNumeric(sArg)
If InStr(sArg, ".") > 0 Then
_CVar = Val(sArg)
Else
_CVar = CLng(Val(sArg)) ' Val always returns a double
End If
Case _RegexSearch(sArg, "^[-+]?[0-9]*\.?[0-9]+(e[-+]?[0-9]+)?$") <> ""
_CVar = Val(sArg) ' Scientific notation
Case Else : _CVar = Replace(Replace(sArg, cstEscape1, "\"), cstEscape2, ";")
End Select

End Function ' CVar V1.7.0
Access2BaseDev Utils _DecimalPoint Basic _FilterOptionsDefault (Procedure)
_PropertyGet (Procedure)
5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _DecimalPoint() As String
'Return locale decimal point
_DecimalPoint = Mid(Format(0, "0.0"), 2, 1)
End Function
Access2BaseDev Utils _ExtensionLocation Basic   10
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _ExtensionLocation() As String
' Return the URL pointing to the location where OO installed the Access2Base extension
' Adapted from http://wiki.services.openoffice.org/wiki/Documentation/DevGuide/Extensions/Location_of_Installed_Extensions

Dim oPip As Object, sLocation As String
Set oPip = GetDefaultContext.getByName("/singletons/com.sun.star.deployment.PackageInformationProvider")
_ExtensionLocation = oPip.getPackageLocation("Access2Base")

End Function ' ExtensionLocation
Access2BaseDev Utils _FinalProperty Basic setValue (Procedure)
getValue (Procedure)
21
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _FinalProperty(psShortcut As String) As String
' Return the final property of a shortcut

Const cstEXCLAMATION = "!"
Const cstDOT = "."

Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String
Dim sComponents() As String, sSubComponents() As String
_FinalProperty = ""
sComponents = Split(Trim(psShortcut), cstEXCLAMATION)
If UBound(sComponents) = 0 Then Exit Function
sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT)
Select Case UBound(sSubComponents)
Case 1
_FinalProperty = sSubComponents(1)
Case Else
Exit Function
End Select

End Function ' FinalProperty
Access2BaseDev Utils _GetDialogLib Basic TraceConsole (Procedure)
_PromptFormat (Procedure)
18
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetDialogLib() As Object
' Return actual Access2Base dialogs library

Dim oDialogLib As Object

Set oDialogLib = DialogLibraries
If oDialogLib.hasByName("Access2BaseDev") Then
If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev")
Set _GetDialogLib = DialogLibraries.Access2BaseDev
ElseIf oDialogLib.hasByName("Access2Base") Then
If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base")
Set _GetDialogLib = DialogLibraries.Access2Base
Else
Set _GetDialogLib = Nothing
EndIf

End Function
Access2BaseDev Utils _GetEventName Basic _GetEventScriptCode (Procedure)
_RegisterDialogEventScript (Procedure)
_RegisterEventScript (Procedure)
_PropertyGet (Procedure)
_PropertyGet (Procedure)
8
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetEventName(ByVal psProperty As String) As String
' Return the LO internal event name
' Corrects the typo on ErrorOccur(r?)ed

_GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) & Right(psProperty, Len(psProperty) - 3), "errorOccurred", "errorOccured")

End Function ' _GetEventName V1.7.0
Access2BaseDev Utils _GetEventScriptCode Basic _PropertyGet (Procedure)
_PropertyGet (Procedure)
_PropertyGet (Procedure)
38
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetEventScriptCode(poObject As Object _
, ByVal psEvent As String _
, ByVal psName As String _
, Optional ByVal pbExtendName As Boolean _
) As String
' Extract from the parent of poObject the macro linked to psEvent.
' psName is the name of the object

Dim i As Integer, vEvents As Variant, sEvent As String, oParent As Object, iIndex As Integer, sName As String

_GetEventScriptCode = ""
If Not Utils._hasUNOMethod(poObject, "getParent") Then Exit Function

' Find form index i.e. find control via getByIndex()
If IsMissing(pbExtendName) Then pbExtendName = False
Set oParent = poObject.getParent()
iIndex = -1
For i = 0 To oParent.getCount() - 1
sName = oParent.getByIndex(i).Name
If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
iIndex = i
Exit For
End If
Next i
If iIndex < 0 Then Exit Function

' Find script event
vEvents = oParent.getScriptEvents(iIndex) ' Returns an array
sEvent = Utils._GetEventName(psEvent) ' Targeted event method
For i = 0 To UBound(vEvents)
If vEvents(i).EventMethod = sEvent Then
_GetEventScriptCode = vEvents(i).ScriptCode
Exit For
End If
Next i

End Function ' _GetEventScriptCode V1.7.0
Access2BaseDev Utils _GetProductName Basic OpenConnection (Procedure)
OpenDatabase (Procedure)
Version (Procedure)
_SendWithAttachment (Procedure)
18
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetProductName(ByVal Optional psFlag As String) as String
'Return OO product ("PRODUCT") and version numbers ("VERSION")
'Derived from Tools library

Dim oProdNameAccess as Object
Dim sVersion as String
Dim sProdName as String
If IsMissing(psFlag) Then psFlag = "ALL"
oProdNameAccess = _GetRegistryKeyContent("org.openoffice.Setup/Product")
sProdName = oProdNameAccess.getByName("ooName")
sVersion = oProdNameAccess.getByName("ooSetupVersionAboutBox")
Select Case psFlag
Case "ALL" : _GetProductName = sProdName & " " & sVersion
Case "PRODUCT" : _GetProductName = sProdName
Case "VERSION" : _GetProductName = sVersion
End Select
End Function ' GetProductName V1.0.0
Access2BaseDev Utils _GetRandomFileName Basic CopyObject (Procedure)
_AppendChunk (Procedure)
9
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetRandomFileName(ByVal psName As String) As String
' Return the full name of a random temporary file suffixed by psName

Dim sRandom As String
sRandom = Right("000000" & Int(999999 * Rnd), 6)
_GetRandomFileName = Utils._getTempDirectoryURL() & "/" & "A2B_TEMP_" & psName & "_" & sRandom

End Function ' GetRandomFileName
Access2BaseDev Utils _GetRegistryKeyContent Basic _GetProductName (Procedure)
_GetLocale (Procedure)
17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean) As Variant
'Implement ConfigurationProvider service
'Derived from Tools library

Dim oConfigProvider as Object
Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
aNodePath(0).Name = "nodepath"
aNodePath(0).Value = sKeyName
If IsMissing(bForUpdate) Then bForUpdate = False
If bForUpdate Then
_GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationUpdateAccess", aNodePath())
Else
_GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", aNodePath())
End If
End Function ' GetRegistryKeyContent V0.8.5
Access2BaseDev Utils _GetResultSetColumnValue Basic CopyObject (Procedure)
FindNext (Procedure)
_DFunction (Procedure)
GetRows (Procedure)
88
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _GetResultSetColumnValue(poResultSet As Object _
, ByVal piColIndex As Integer _
, Optional ByVal pbReturnBinary As Boolean _
) As Variant
REM Modified from Roberto Benitez's BaseTools
REM get the data for the column specified by ColIndex
REM If pbReturnBinary = False (default) then return length of binary field
REM get type name from metadata

Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object
Dim bNullable As Boolean, lSize As Long
Const cstMaxTextLength = 65535
Const cstMaxBinlength = 2 * 65535

On Local Error Goto 0 ' Disable error handler
vValue = Null ' Default value if error
If IsMissing(pbReturnBinary) Then pbReturnBinary = False
With com.sun.star.sdbc.DataType
iType = poResultSet.MetaData.getColumnType(piColIndex)
bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )
Select Case iType
Case .ARRAY : vValue = poResultSet.getArray(piColIndex)
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
Set oValue = poResultSet.getBinaryStream(piColIndex)
If bNullable Then
If Not poResultSet.wasNull() Then
If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset
lSize = cstMaxBinLength
Else
lSize = CLng(oValue.getLength())
End If
If lSize <= cstMaxBinLength And pbReturnBinary Then
vValue = Array()
oValue.readBytes(vValue, lSize)
Else ' Return length of field, not content
vValue = lSize
End If
End If
End If
oValue.closeInput()
Case .BIT, .BOOLEAN : vValue = poResultSet.getBoolean(piColIndex)
Case .DATE : vDateTime = poResultSet.getDate(piColIndex)
If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
vValue = Null
Case .DOUBLE, .REAL : vValue = poResultSet.getDouble(piColIndex)
Case .FLOAT : vValue = poResultSet.getFloat(piColIndex)
Case .INTEGER, .SMALLINT : vValue = poResultSet.getInt(piColIndex)
Case .BIGINT : vValue = poResultSet.getLong(piColIndex)
Case .DECIMAL, .NUMERIC : vValue = poResultSet.getDouble(piColIndex)
Case .SQLNULL : vValue = poResultSet.getNull(piColIndex)
Case .OBJECT, .OTHER, .STRUCT : vValue = Null
Case .REF : vValue = poResultSet.getRef(piColIndex)
Case .TINYINT : vValue = poResultSet.getShort(piColIndex)
Case .CHAR, .VARCHAR : vValue = poResultSet.getString(piColIndex)
Case .LONGVARCHAR, .CLOB
Set oValue = poResultSet.getCharacterStream(piColIndex)
If bNullable Then
If Not poResultSet.wasNull() Then
If Not _hasUNOMethod(oValue, "getLength") Then ' When no recordset
lSize = cstMaxTextLength
Else
lSize = CLng(oValue.getLength())
End If
oValue.closeInput()
vValue = poResultSet.getString(piColIndex)
End If
Else
oValue.closeInput()
End If
Case .TIME : vDateTime = poResultSet.getTime(piColIndex)
If Not poResultSet.wasNull() Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
Case .TIMESTAMP : vDateTime = poResultSet.getTimeStamp(piColIndex)
If Not poResultSet.wasNull() Then vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
+ TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
Case Else
vValue = poResultSet.getString(piColIndex) 'GIVE STRING A TRY
If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
End Select
If bNullable Then
If poResultSet.wasNull() Then vValue = Null
End If
End With

_GetResultSetColumnValue = vValue

End Function ' GetResultSetColumnValue V 1.5.0
Access2BaseDev Utils _getTempDirectoryURL Basic SendObject (Procedure)
_GetRandomFileName (Procedure)
20
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _getTempDirectoryURL() As String
' Return the temporary directory defined in the OO Options (Paths)
Dim sDirectory As String, oSettings As Object, oPathSettings As Object

If _ErrorHandler() Then On Local Error Goto Error_Function

_getTempDirectoryURL = ""
oPathSettings = createUnoService( "com.sun.star.util.PathSettings" )
sDirectory = oPathSettings.GetPropertyValue( "Temp" )

_getTempDirectoryURL = sDirectory

Exit_Function:
Exit Function
Error_Function:
TraceError("ERROR", Err, "_getTempDirectoryURL", Erl)
_getTempDirectoryURL = ""
Goto Exit_Function
End Function ' _getTempDirectoryURL V0.8.5
Access2BaseDev Utils _getUNOTypeName Basic _ImplementationName (Procedure)
_Initialize (Procedure)
16
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _getUNOTypeName(pvObject As Variant) As String
' Return the symbolic name of the pvObject (UNO-object) type
' Code-snippet from XRAY

Dim oService As Object, vClass as Variant
_getUNOTypeName = ""
On Local Error Resume Next
oService = CreateUnoService("com.sun.star.reflection.CoreReflection")
vClass = oService.getType(pvObject)
If vClass.TypeClass = com.sun.star.uno.TypeClass.STRUCT Then
_getUNOTypeName = vClass.Name
End If
oService.Dispose()

End Function ' getUNOTypeName
Access2BaseDev Utils _hasUNOMethod Basic _NewBar (Procedure)
_GetEventScriptCode (Procedure)
_GetResultSetColumnValue (Procedure)
_RegisterDialogEventScript (Procedure)
_RegisterEventScript (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolean
' Return true if pvObject has the (UNO) method psMethod
' Code-snippet found in Bernard Marcelly's XRAY

Dim vInspect as Variant
_hasUNOMethod = False
If IsNull(pvObject) Then Exit Function
On Local Error Resume Next
vInspect = _A2B_.Introspection.Inspect(pvObject)
_hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL)

End Function ' hasUNOMethod V0.8.0
Access2BaseDev Utils _hasUNOProperty Basic Events (Procedure)
OpenConnection (Procedure)
Maximize (Procedure)
Minimize (Procedure)
MoveSize (Procedure)
_SelectWindow (Procedure)
Controls (Procedure)
Move (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_Initialize (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CreateField (Procedure)
AddNew (Procedure)
Fields (Procedure)
CurrentDocIndex (Procedure)
13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Boolean
' Return true if pvObject has the (UNO) property psProperty
' Code-snippet found in Bernard Marcelly's XRAY

Dim vInspect as Variant
_hasUNOProperty = False
If IsNull(pvObject) Then Exit Function
On Local Error Resume Next
vInspect = _A2B_.Introspection.Inspect(pvObject)
_hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)

End Function ' hasUNOProperty V0.8.0
Access2BaseDev Utils _ImplementationName Basic _CStr (Procedure)
_Initialize (Procedure)
_Initialize (Procedure)
12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ImplementationName(pvObject As Variant) As String
' Use getImplementationName method or _getUNOTypeName function

Dim sObjectType As String
On Local Error Resume Next
sObjectType = pvObject.getImplementationName()
If sObjectType = "" Then sObjectType = _getUNOTypeName(pvObject)

_ImplementationName = sObjectType

End Function ' ImplementationName
Access2BaseDev Utils _InList Basic AllForms (Procedure)
TraceLevel (Procedure)
_CheckColumnType (Procedure)
_IsPseudo (Procedure)
_IsScalar (Procedure)
Delete (Procedure)
getObject (Procedure)
_hasProperty (Procedure)
_GetLabel (Procedure)
Requery (Procedure)
_ListboxBound (Procedure)
61
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Optional pvReturnValue As Variant, Optional ByVal pbBinarySearch As Boolean) As Variant
' Return True if pvItem is present in the pvList array (case insensitive comparison)
' Return the value in pvList if pvReturnValue = True

Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer
Dim iTop As Integer, iBottom As Integer, iFound As Integer
iItemVarType = VarType(pvItem)
If IsMissing(pvReturnValue) Then pvReturnValue = False
If iItemVarType = vbNull Or IsNull(pvList) Then
_InList = False
ElseIf Not IsArray(pvList) Then
If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList )
If Not pvReturnValue Then
_InList = bFound
Else
If bFound Then _InList = pvList Else _InList = False
End If
ElseIf UBound(pvList) < LBound(pvList) Then ' Array not initialized
_InList = False
Else
bFound = False
_InList = False
iListVarType = VarType(pvList(LBound(pvList)))
If iListVarType = iItemVarType _
Or ( (iListVarType = vbInteger Or iListVarType = vbLong Or iListVarType = vbSingle Or iListVarType = vbDouble _
Or iListVarType = vbCurrency Or iListVarType = vbBigint Or iListVarType = vbDecimal) _
And (iItemVarType = vbInteger Or iItemVarType = vbLong Or iItemVarType = vbSingle Or iItemVarType = vbDouble _
Or iItemVarType = vbCurrency Or iItemVarType = vbBigint Or iItemVarType = vbDecimal) _
) Then
If IsMissing(pbBinarySearch) Then pbBinarySearch = False
If Not pbBinarySearch Then ' Linear search
For i = LBound(pvList) To UBound(pvList)
If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) )
If bFound Then
iFound = i
Exit For
End If
Next i
Else ' Binary search => array must be sorted
iTop = UBound(pvList)
iBottom = lBound(pvList)
Do
iFound = (iTop + iBottom) / 2
If ( iItemVarType = vbString And UCase(pvItem) > UCase(pvList(iFound)) ) Or ( iItemVarType <> vbString And pvItem > pvList(iFound) ) Then
iBottom = iFound + 1
Else
iTop = iFound - 1
End If
If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) )
Loop Until ( bFound ) Or ( iBottom > iTop )
End If
If bFound Then
If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound)
End If
End If
End If

Exit Function

End Function ' InList V1.1.0
Access2BaseDev Utils _InspectPropertyType Basic _PropertySet (Procedure) 16
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String
'Return type of property EVEN WHEN EMPTY ! (Used in date and time controls)

Dim oInspect1 As Object, oInspect2 As Object, oInspect3 As Object
' On Local Error Resume Next
_InspectPropertyType = ""
Set oInspect1 = CreateUnoService("com.sun.star.script.Invocation")
Set oInspect2 = oInspect1.createInstanceWithArguments(Array(poObject)).IntroSpection
If Not IsNull(oInspect2) Then
Set oInspect3 = oInspect2.getProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
If Not IsNull(oInspect3) Then _InspectPropertyType = oInspect3.Type.Name
End If
Set oInspect1 = Nothing : Set oInspect2 = Nothing : Set oInspect3 = Nothing

End Function ' InspectPropertyType V1.0.0
Access2BaseDev Utils _IsBinaryType Basic CopyObject (Procedure)
_OutputDataToHTML (Procedure)
13
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _IsBinaryType(ByVal lType As Long) As Boolean

With com.sun.star.sdbc.DataType
Select Case lType
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
_IsBinaryType = True
Case Else
_IsBinaryType = False
End Select
End With

End Function ' IsBinaryType V1.6.0
Access2BaseDev Utils _IsLeft Basic CommandBars (Procedure)
RunCommand (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
Execute (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
12
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _IsLeft(psString As String, psLeft As String) As Boolean
' Return True if left part of psString = psLeft

Dim iLength As Integer
iLength = Len(psLeft)
_IsLeft = False
If Len(psString) >= iLength Then
If Left(psString, iLength) = psLeft Then _IsLeft = True
End If

End Function
Access2BaseDev Utils _IsPseudo Basic _CheckArgument (Procedure)
_CStr (Procedure)
103
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As Boolean
' Test pvObject: does it exist ?
' is the _Type item = one of the proposed pvTypes ?
' does the pseudo-object refer to an existing object (e.g. does the form really exist in the db) ?

Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant

If _ErrorHandler() Then On Local Error Goto Exit_False

_IsPseudo = False
bIsPseudo = False
vObject = pvObject ' To avoid "Object variable not set" error message
Select Case True
Case IsEmpty(vObject)
Case IsNull(vObject)
Case VarType(vObject) <> vbObject
Case Else
With vObject
Select Case True
Case IsEmpty(._Type)
Case IsNull(._Type)
Case ._Type = ""
Case Else
bIsPseudo = _InList(._Type, pvType)
If Not bIsPseudo Then ' If primary type did not succeed, give the subtype a chance
If ._Type = OBJCONTROL Then bIsPseudo = _InList(._SubType, pvType)
End If
End Select
End With
End Select

If Not bIsPseudo Then Goto Exit_Function

Dim oDoc As Object, oForms As Variant

bPseudoExists = False
With vObject
Select Case ._Type
Case OBJFORM
If ._Name <> "" Then ' Check validity of form name
Set oDoc = _A2B_.CurrentDocument()
If oDoc.DbConnect = DBCONNECTFORM Then
bPseudoExists = True
Else
Set oForms = oDoc.Document.getFormDocuments()
bPseudoExists = ( oForms.HasByName(._Name) )
End If
End If
Case OBJDATABASE
If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection)
Case OBJDIALOG
If ._Name <> "" Then ' Check validity of dialog name
bPseudoExists = ( _A2B_.hasItem(COLLALLDIALOGS, ._Name) )
End If
Case OBJCOLLECTION
bPseudoExists = True
Case OBJCONTROL
If Not IsNull(.ControlModel) And ._Name <> "" Then ' Check validity of control
Set oForms = .ControlModel.Parent
bPseudoExists = ( oForms.hasByName(._Name) )
End If
Case OBJSUBFORM
If Not IsNull(.DatabaseForm) And ._Name <> "" Then ' Check validity of subform
If .DatabaseForm.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then
Set oForms = .DatabaseForm.Parent
bPseudoExists = ( oForms.hasByName(._Name) )
End If
End If
Case OBJOPTIONGROUP
bPseudoExists = ( .Count > 0 )
Case OBJCOMMANDBAR
bPseudoExists = ( Not IsNull(._Window) )
Case OBJCOMMANDBARCONTROL
bPseudoExists = ( Not IsNull(._ParentCommandBar) )
Case OBJEVENT
bPseudoExists = ( Not IsNull(._EventSource) )
Case OBJPROPERTY
bPseudoExists = ( ._Name <> "" )
Case OBJTABLEDEF
bPseudoExists = ( ._Name <> "" And Not IsNull(.Table) )
Case OBJQUERYDEF
bPseudoExists = ( ._Name <> "" And Not IsNull(.Query) )
Case OBJRECORDSET
bPseudoExists = ( Not IsNull(.RowSet) )
Case OBJFIELD
bPseudoExists = ( ._Name <> "" And Not IsNull(.Column) )
Case OBJTEMPVAR
If ._Name <> "" Then ' Check validity of tempvar name
bPseudoExists = ( _A2B_.hasItem(COLLTEMPVARS, ._Name) )
End If
Case Else
End Select
End With

_IsPseudo = ( bIsPseudo And bPseudoExists )

Exit_Function:
Exit Function
Exit_False:
_IsPseudo = False
Goto Exit_Function
End Function ' IsPseudo V1.1.0
Access2BaseDev Utils _IsScalar Basic _CheckArgument (Procedure)
_PropertySet (Procedure)
24
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _IsScalar(ByVal pvArg As Variant, Byval pvType As Variant, ByVal Optional pvValid As Variant) As Boolean
' Check type of pvArg and value in allowed pvValid list

_IsScalar = False

If IsArray(pvType) Then
If Not _InList(VarType(pvArg), pvType) Then Exit Function
ElseIf VarType(pvArg) <> pvType Then
If pvType = vbBoolean And VarType(pvArg) = vbLong Then
If pvArg < -1 And pvArg > 0 Then Exit Function ' Special boolean processing because the Not function returns a Long
Else
Exit Function
End If
End If
If Not IsMissing(pvValid) Then
If Not _InList(pvArg, pvValid) Then Exit Function
End If

_IsScalar = True

Exit_Function:
Exit Function
End Function ' IsScalar V0.7.5
Access2BaseDev Utils _PCase Basic Properties (Procedure)
Properties (Procedure)
_hasProperty (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
Execute (Procedure)
Fields (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
OpenRecordset (Procedure)
Properties (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OpenRecordset (Procedure)
Properties (Procedure)
Properties (Procedure)
setProperty (Procedure)
Properties (Procedure)
Properties (Procedure)
Properties (Procedure)
17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _PCase(ByVal psString As String) As String
' Return the proper case representation of argument

Dim vSubStrings() As Variant, i As Integer, iLen As Integer
vSubStrings = Split(psString, " ")
For i = 0 To UBound(vSubStrings)
iLen = Len(vSubStrings(i))
If iLen > 1 Then
vSubStrings(i) = UCase(Left(vSubStrings(i), 1)) & LCase(Right(vSubStrings(i), iLen - 1))
ElseIf iLen = 1 Then
vSubStrings(i) = UCase(vSubStrings(i))
End If
Next i
_PCase = Join(vSubStrings, " ")

End Function ' PCase V0.9.0
Access2BaseDev Utils _PercentEncode Basic _URLEncode (Procedure) 35
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PercentEncode(ByVal psChar As String) As String
' Percent encoding of single psChar character
' https://en.wikipedia.org/wiki/UTF-8

Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String
lChar = Asc(psChar)

Select Case lChar
Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z
_PercentEncode = psChar
Case Asc("-"), Asc("."), Asc("_"), Asc("~")
_PercentEncode = psChar
Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimiters in query strings
_PercentEncode = psChar
Case Asc(" "), Asc("%")
_PercentEncode = "%" & Right("00" & Hex(lChar), 2)
Case 0 To 127
_PercentEncode = psChar
Case 128 To 2047
sByte1 = "%" & Right("00" & Hex(Int(lChar / 64) + 192), 2)
sByte2 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
_PercentEncode = sByte1 & sByte2
Case 2048 To 65535
sByte1 = "%" & Right("00" & Hex(Int(lChar / 4096) + 224), 2)
sByte2 = "%" & Right("00" & Hex(Int(lChar - (4096 * Int(lChar / 4096))) /64 + 128), 2)
sByte3 = "%" & Right("00" & Hex((lChar Mod 64) + 128), 2)
_PercentEncode = sByte1 & sByte2 & sByte3
Case Else ' Not supported
_PercentEncode = psChar
End Select

Exit Function

End Function ' _PercentEncode V1.4.0
Access2BaseDev Utils _ReadFileIntoArray Basic _OutputToHTML (Procedure) 39
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _ReadFileIntoArray(ByVal psFileName) As Variant
' Loads all lines of a text file into a variant array
' Any error reduces output to an empty array
' Input file name presumed in URL form

Dim vLines() As Variant, iFile As Integer, sLine As String, iCount1 As Integer, iCount2 As Integer
Const cstMaxLines = 16000 ' +/- the limit of array sizes in Basic
On Local Error GoTo Error_Function
vLines = Array()
_ReadFileIntoArray = Array()
If psFileName = "" Then Exit Function

iFile = FreeFile()
Open psFileName For Input Access Read Shared As #iFile
iCount1 = 0
Do While Not Eof(iFile) And iCount1 < cstMaxLines
Line Input #iFile, sLine
iCount1 = iCount1 + 1
Loop
Close #iFile

ReDim vLines(0 To iCount1 - 1) ' Reading file twice preferred to ReDim Preserve for performance reasons
iFile = FreeFile()
Open psFileName For Input Access Read Shared As #iFile
iCount2 = 0
Do While Not Eof(iFile) And iCount2 < iCount1
Line Input #iFile, vLines(iCount2)
iCount2 = iCount2 + 1
Loop
Close #iFile

Exit_Function:
_ReadFileIntoArray() = vLines()
Exit Function
Error_Function:
vLines = Array()
Resume Exit_Function
End Function ' _ReadFileIntoArray V1.4.0
Access2BaseDev Utils _RegexSearch Basic _CVar (Procedure)
_StrToPropValues (Procedure)
Find (Procedure)
_FindPattern (Procedure)
49
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RegexSearch(ByRef psString As String _
, ByVal psRegex As String _
, Optional ByRef plStart As Long _
, Optional ByVal bForward As Boolean _
) As String
' Search is not case-sensitive
' Return "" if regex not found, otherwise returns the matching string
' plStart = start position of psString to search (starts at 1)
' In output plStart contains the first position of the matching string
' To search again the same or another pattern => plStart = plStart + Len(matching string)

Dim oTextSearch As Object
Dim vOptions As Variant 'com.sun.star.util.SearchOptions
Dim lEnd As Long, vResult As Object

_RegexSearch = ""
Set oTextSearch = _A2B_.TextSearch ' UNO XTextSearch service
vOptions = _A2B_.SearchOptions
vOptions.searchString = psRegex ' Pattern to be searched
oTextSearch.setOptions(vOptions)
If IsMissing(plStart) Then plStart = 1
If plStart <= 0 Or plStart > Len(psString) Then Exit Function
If IsMissing(bForWard) Then bForward = True
If bForward Then
lEnd = Len(psString)
vResult = oTextSearch.searchForward(psString, plStart - 1, lEnd)
Else
lEnd = 1
vResult = oTextSearch.searchForward(psString, plStart, lEnd - 1)
End If
With vResult
If .subRegExpressions >= 1 Then
' http://www.openoffice.org/api/docs/common/ref/com/sun/star/util/SearchResult.html
Select Case bForward
Case True
plStart = .startOffset(0) + 1
lEnd = .endOffset(0) + 1
Case False
plStart = .endOffset(0) + 1
lEnd = .startOffset(0)
End Select
_RegexSearch = Mid(psString, plStart, lEnd - plStart)
Else
plStart = 0
End If
End With

End Function
Access2BaseDev Utils _RegisterDialogEventScript Basic _PropertySet (Procedure)
_PropertySet (Procedure)
30
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RegisterDialogEventScript(poObject As Object _
, ByVal psEvent As String _
, ByVal psListener As String _
, ByVal psScriptCode As String _
) As Boolean
' Register a script event (psEvent) to poObject (Dialog or dialog Control)

Dim oEvents As Object, sEvent As String, sEventName As String, oEvent As Object

_RegisterDialogEventScript = False
If Not _hasUNOMethod(poObject, "getEvents") Then Exit Function

' Remove existing event, if any, than store new script code
Set oEvents = poObject.getEvents()
sEvent = Utils._GetEventName(psEvent)
sEventName = "com.sun.star.awt." & psListener & "::" & sEvent
If oEvents.hasByName(sEventName) Then oEvents.removeByName(sEventName)
Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
With oEvent
.ListenerType = psListener
.EventMethod = sEvent
.ScriptType = "Script" ' Better than "Basic"
.ScriptCode = psScriptCode
End With
oEvents.insertByName(sEventName, oEvent)

_RegisterDialogEventScript = True

End Function ' _RegisterDialogEventScript V1.8.0
Access2BaseDev Utils _RegisterEventScript Basic _PropertySet (Procedure)
_PropertySet (Procedure)
_PropertySet (Procedure)
44
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RegisterEventScript(poObject As Object _
, ByVal psEvent As String _
, ByVal psListener As String _
, ByVal psScriptCode As String _
, ByVal psName As String _
, Optional ByVal pbExtendName As Boolean _
) As Boolean
' Register a script event (psEvent) to poObject (Form, SubForm or Control)

Dim i As Integer, oEvent As Object, sEvent As String, oParent As Object, iIndex As Integer, sName As String

_RegisterEventScript = False
If Not _hasUNOMethod(poObject, "getParent") Then Exit Function

' Find object internal index i.e. how to reach it via getByIndex()
If IsMissing(pbExtendName) Then pbExtendName = False
Set oParent = poObject.getParent()
iIndex = -1
For i = 0 To oParent.getCount() - 1
sName = oParent.getByIndex(i).Name
If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
iIndex = i
Exit For
End If
Next i
If iIndex < 0 Then Exit Function

sEvent = Utils._GetEventName(psEvent) ' Targeted event method
If psScriptCode = "" Then
oParent.revokeScriptEvent(iIndex, psListener, sEvent, "")
Else
Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
With oEvent
.ListenerType = psListener
.EventMethod = sEvent
.ScriptType = "Script" ' Better than "Basic"
.ScriptCode = psScriptCode
End With
oParent.registerScriptEvent(iIndex, oEvent)
End If
_RegisterEventScript = True

End Function ' _RegisterEventScript V1.7.0
Access2BaseDev Utils _ResetCalledSub Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CloseConnection (Procedure)
CommandBars (Procedure)
Controls (Procedure)
CurrentDb (Procedure)
DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
Events (Procedure)
Forms (Procedure)
HtmlEncode (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
AddItem (Procedure)
hasProperty (Procedure)
Move (Procedure)
Properties (Procedure)
Refresh (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
SetFocus (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindNext (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
Maximize (Procedure)
Minimize (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OpenQuery (Procedure)
OpenReport (Procedure)
OpenSQL (Procedure)
OpenTable (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunApp (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
mClose (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
getProperty (Procedure)
OpenRecordset (Procedure)
OutputTo (Procedure)
Properties (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_PropertyGet (Procedure)
setProperty (Procedure)
setValue (Procedure)
_setProperty (Procedure)
Item (Procedure)
Add (Procedure)
Delete (Procedure)
getProperty (Procedure)
Remove (Procedure)
RemoveAll (Procedure)
_PropertyGet (Procedure)
getObject (Procedure)
getOptionGroup (Procedure)
getProperty (Procedure)
getValue (Procedure)
_getProperty (Procedure)
_hasProperty (Procedure)
_Properties (Procedure)
IsLoaded (Procedure)
OptionGroup (Procedure)
mClose (Procedure)
Controls (Procedure)
CurrentDb (Procedure)
getProperty (Procedure)
Move (Procedure)
Refresh (Procedure)
Requery (Procedure)
setFocus (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
DebugPrint (Procedure)
OptionGroup (Procedure)
Parent (Procedure)
Controls (Procedure)
getProperty (Procedure)
Refresh (Procedure)
Requery (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
getProperty (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
getProperty (Procedure)
_PropertyGet (Procedure)
getProperty (Procedure)
_PropertyGet (Procedure)
Properties (Procedure)
AddItem (Procedure)
Controls (Procedure)
getProperty (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
setFocus (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Properties (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Execute (Procedure)
getProperty (Procedure)
Move (Procedure)
setProperty (Procedure)
Start (Procedure)
Terminate (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AppendChunk (Procedure)
GetChunk (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
Properties (Procedure)
ReadAllBytes (Procedure)
ReadAllText (Procedure)
setProperty (Procedure)
WriteAllBytes (Procedure)
WriteAllText (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CreateField (Procedure)
Execute (Procedure)
Fields (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
OpenRecordset (Procedure)
Properties (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AddNew (Procedure)
CancelUpdate (Procedure)
Clone (Procedure)
mClose (Procedure)
Delete (Procedure)
Edit (Procedure)
Fields (Procedure)
getProperty (Procedure)
GetRows (Procedure)
hasProperty (Procedure)
OpenRecordset (Procedure)
Properties (Procedure)
setProperty (Procedure)
Update (Procedure)
_Move (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
getProperty (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CommandBarControls (Procedure)
Controls (Procedure)
getProperty (Procedure)
Reset (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Execute (Procedure)
getProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Lines (Procedure)
ProcBodyLine (Procedure)
ProcCountLines (Procedure)
ProcOfLine (Procedure)
ProcStartLine (Procedure)
Properties (Procedure)
Find (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
_PropertyGet (Procedure)
8
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _ResetCalledSub(ByVal psSub As String)
' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling
' Used to trace routine in/outs and to clarify error messages
If IsEmpty(_A2B_) Then Call Application._RootInit() ' Only is Utils module recompiled
If _A2B_.CalledSub = psSub Then _A2B_.CalledSub = ""
If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False)
End Sub ' ResetCalledSub
Access2BaseDev Utils _RunScript Basic Execute (Procedure) 22
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _RunScript(ByVal psScript As String, Optional pvArgs() As Variant) As Boolean
' Execute a given script with pvArgs() array of arguments

On Local Error Goto Error_Function
_RunScript = False
If IsNull(ThisComponent) Then Goto Exit_Function

Dim oSCriptProvider As Object, oScript As Object, vResult As Variant

Set oScriptProvider = ThisComponent.ScriptProvider()
Set oScript = oScriptProvider.getScript(psScript)
If IsMissing(pvArgs()) Then pvArgs() = Array()
vResult = oScript.Invoke(pvArgs(), Array(), Array())
_RunScript = True

Exit_Function:
Exit Function
Error_Function:
_RunScript = False
Goto Exit_Function
End Function
Access2BaseDev Utils _SetCalledSub Basic AllDialogs (Procedure)
AllForms (Procedure)
AllModules (Procedure)
CloseConnection (Procedure)
CommandBars (Procedure)
Controls (Procedure)
CurrentDb (Procedure)
DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
Events (Procedure)
Forms (Procedure)
HtmlEncode (Procedure)
OpenConnection (Procedure)
OpenDatabase (Procedure)
SysCmd (Procedure)
TempVars (Procedure)
AddItem (Procedure)
hasProperty (Procedure)
Move (Procedure)
Properties (Procedure)
Refresh (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
SetFocus (Procedure)
_TraceArguments (Procedure)
ApplyFilter (Procedure)
mClose (Procedure)
CopyObject (Procedure)
FindNext (Procedure)
FindRecord (Procedure)
GetHiddenAttribute (Procedure)
GoToControl (Procedure)
GoToRecord (Procedure)
Maximize (Procedure)
Minimize (Procedure)
MoveSize (Procedure)
OpenForm (Procedure)
OpenQuery (Procedure)
OpenReport (Procedure)
OpenSQL (Procedure)
OpenTable (Procedure)
OutputTo (Procedure)
Quit (Procedure)
RunApp (Procedure)
RunCommand (Procedure)
RunSQL (Procedure)
SelectObject (Procedure)
SendObject (Procedure)
SetHiddenAttribute (Procedure)
SetOrderBy (Procedure)
ShowAllrecords (Procedure)
mClose (Procedure)
CreateQueryDef (Procedure)
CreateTableDef (Procedure)
DAvg (Procedure)
DCount (Procedure)
DLookup (Procedure)
DMax (Procedure)
DMin (Procedure)
DStDev (Procedure)
DStDevP (Procedure)
DSum (Procedure)
DVar (Procedure)
DVarP (Procedure)
getProperty (Procedure)
OpenRecordset (Procedure)
OpenSQL (Procedure)
OutputTo (Procedure)
Properties (Procedure)
QueryDefs (Procedure)
Recordsets (Procedure)
RunSQL (Procedure)
TableDefs (Procedure)
_PropertyGet (Procedure)
setProperty (Procedure)
setValue (Procedure)
_setProperty (Procedure)
Item (Procedure)
Add (Procedure)
Delete (Procedure)
getProperty (Procedure)
Remove (Procedure)
RemoveAll (Procedure)
_PropertyGet (Procedure)
getObject (Procedure)
getOptionGroup (Procedure)
getProperty (Procedure)
getValue (Procedure)
_getProperty (Procedure)
_hasProperty (Procedure)
_Properties (Procedure)
IsLoaded (Procedure)
OptionGroup (Procedure)
mClose (Procedure)
Controls (Procedure)
CurrentDb (Procedure)
getProperty (Procedure)
Move (Procedure)
Refresh (Procedure)
Requery (Procedure)
setFocus (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
DebugPrint (Procedure)
OptionGroup (Procedure)
Parent (Procedure)
Controls (Procedure)
getProperty (Procedure)
Refresh (Procedure)
Requery (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Controls (Procedure)
getProperty (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
getProperty (Procedure)
_PropertyGet (Procedure)
getProperty (Procedure)
_PropertyGet (Procedure)
Properties (Procedure)
AddItem (Procedure)
Controls (Procedure)
getProperty (Procedure)
RemoveItem (Procedure)
Requery (Procedure)
setFocus (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
OptionGroup (Procedure)
Properties (Procedure)
Controls (Procedure)
EndExecute (Procedure)
Execute (Procedure)
getProperty (Procedure)
Move (Procedure)
setProperty (Procedure)
Start (Procedure)
Terminate (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AppendChunk (Procedure)
GetChunk (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
Properties (Procedure)
ReadAllBytes (Procedure)
ReadAllText (Procedure)
setProperty (Procedure)
WriteAllBytes (Procedure)
WriteAllText (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CreateField (Procedure)
Execute (Procedure)
Fields (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
OpenRecordset (Procedure)
Properties (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
AddNew (Procedure)
CancelUpdate (Procedure)
Clone (Procedure)
mClose (Procedure)
Delete (Procedure)
Edit (Procedure)
Fields (Procedure)
getProperty (Procedure)
GetRows (Procedure)
hasProperty (Procedure)
OpenRecordset (Procedure)
Properties (Procedure)
setProperty (Procedure)
Update (Procedure)
_Move (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
getProperty (Procedure)
setProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
CommandBarControls (Procedure)
Controls (Procedure)
getProperty (Procedure)
Reset (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Execute (Procedure)
getProperty (Procedure)
_PropertyGet (Procedure)
_PropertySet (Procedure)
Lines (Procedure)
ProcBodyLine (Procedure)
ProcCountLines (Procedure)
ProcOfLine (Procedure)
ProcStartLine (Procedure)
Properties (Procedure)
Find (Procedure)
getProperty (Procedure)
hasProperty (Procedure)
_PropertyGet (Procedure)
8
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _SetCalledSub(ByVal psSub As String)
' Called in top of each public function.
' Used to trace routine in/outs and to clarify error messages
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session
If _A2B_.CalledSub = "" Then _A2B_.CalledSub = psSub
If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Entering") & " " & psSub & " ...", False)
End Sub ' SetCalledSub
Access2BaseDev Utils _Surround Basic CopyObject (Procedure)
_getUpperShortcut (Procedure)
Controls (Procedure)
_Initialize (Procedure)
Controls (Procedure)
_Initialize (Procedure)
Controls (Procedure)
Controls (Procedure)
20
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Surround(ByVal psName As String) As String
' Return [Name] if Name contains spaces
' Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots

Const cstSquareOpen = "["
Const cstSquareClose = "]"
Const cstDot = "."
Dim sName As String

If InStr(psName, ".") > 0 Then
sName = Join(Split(psName, cstDot), cstSquareClose & cstDot & cstSquareOpen)
_Surround = cstSquareOpen & sName & cstSquareClose
ElseIf InStr(psName, " ") > 0 Then
_Surround = cstSquareOpen & psName & cstSquareClose
Else
_Surround = psName
End If

End Function ' Surround
Access2BaseDev Utils _Trim Basic AllForms (Procedure)
Forms (Procedure)
_OptionGroup (Procedure)
_DatabaseForm (Procedure)
getObject (Procedure)
Controls (Procedure)
Controls (Procedure)
Controls (Procedure)
Controls (Procedure)
_PropertyGet (Procedure)
ProcStartLine (Procedure)
17
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _Trim(ByVal psString As String) As String
' Remove leading and trailing spaces, remove surrounding square brackets, replace tabs by spaces
Const cstSquareOpen = "["
Const cstSquareClose = "]"
Dim sTrim As String

sTrim = Trim(Replace(psString, vbTab, " "))
_Trim = sTrim
If Len(sTrim) <= 2 Then Exit Function

If Left(sTrim, 1) = cstSquareOpen Then
If Right(sTrim, 1) = cstSquareClose Then
_Trim = Mid(sTrim, 2, Len(sTrim) - 2)
End If
End If
End Function ' Trim V0.9.0
Access2BaseDev Utils _TrimArray Basic AllDialogs (Procedure)
AllModules (Procedure)
_Initialize (Procedure)
_PropertiesList (Procedure)
34
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _TrimArray(pvArray As Variant) As Variant
' Remove empty strings from strings array

Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As Integer
vTrim = Null
If Not IsArray(pvArray) Then
If Len(Trim(pvArray)) > 0 Then vTrim = Array(pvArray) Else vTrim = Array()
ElseIf UBound(pvArray) < LBound(pvArray) Then ' Array empty
vTrim = Array()
Else
iCount = 0
For i = LBound(pvArray) To UBound(pvArray)
If Len(Trim(pvArray(i))) = 0 Then iCount = iCount + 1
Next i
If iCount = 0 Then
vTrim() = pvArray()
ElseIf iCount = UBound(pvArray) - LBound(pvArray) + 1 Then ' Array empty or all blanks
vTrim() = Array()
Else
ReDim vTrim(LBound(pvArray) To UBound(pvArray) - iCount)
j = 0
For i = LBound(pvArray) To UBound(pvArray)
If Len(Trim(pvArray(i))) > 0 Then
vTrim(j) = pvArray(i)
j = j + 1
End If
Next i
End If
End If

_TrimArray() = vTrim()

End Function ' TrimArray V0.9.0
Access2BaseDev Utils _UpdateResultSetColumnValue Basic CopyObject (Procedure) 74
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _
, poResultSet As Object _
, ByVal piColIndex As Integer _
, ByVal pvValue As Variant _
) As Boolean
REM store the pvValue for the column specified by ColIndex
REM get type name from metadata

Dim iType As Integer, vDateTime As Variant, oValue As Object
Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName As String
Const cstMaxTextLength = 65535
Const cstMaxBinlength = 2 * 65535

On Local Error Goto 0 ' Disable error handler
_UpdateResultSetColumnValue = False
With com.sun.star.sdbc.DataType
iType = poResultSet.MetaData.getColumnType(piColIndex)
iValueType = VarType(pvValue)
sValueTypeName = UCase(poResultSet.MetaData.getColumnTypeName(piColIndex))
bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE )

If bNullable And IsNull(pvValue) Then
poResultSet.updateNull(piColIndex)
Else
Select Case iType
Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF, .SQLNULL, .STRUCT
poResultSet.updateNull(piColIndex)
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
poResultSet.updateBytes(piColIndex, pvValue)
Case .BIT, .BOOLEAN : poResultSet.updateBoolean(piColIndex, pvValue)
Case .DATE : vDateTime = CreateUnoStruct("com.sun.star.util.Date")
vDateTime.Year = Year(pvValue)
vDateTime.Month = Month(pvValue)
vDateTime.Day = Day(pvValue)
poResultSet.updateDate(piColIndex, vDateTime)
Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue)
Case .DOUBLE, .REAL : poResultSet.updateDouble(piColIndex, pvValue)
Case .FLOAT : poResultSet.updateFloat(piColIndex, pvValue)
Case .INTEGER, .SMALLINT : poResultSet.updateInt(piColIndex, pvValue)
Case .BIGINT : poResultSet.updateLong(piColIndex, pvValue)
Case .DECIMAL, .NUMERIC : poResultSet.updateDouble(piColIndex, pvValue)
Case .TINYINT : poResultSet.updateShort(piColIndex, pvValue)
Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
If piRDBMS = DBMS_SQLITE And InStr(sValueTypeName, "BINARY") > 0 Then ' Sqlite exception ... !
poResultSet.updateBytes(piColIndex, pvValue)
Else
poResultSet.updateString(piColIndex, pvValue)
End If
Case .TIME : vDateTime = CreateUnoStruct("com.sun.star.util.Time")
vDateTime.Hours = Hour(pvValue)
vDateTime.Minutes = Minute(pvValue)
vDateTime.Seconds = Second(pvValue)
'vDateTime.HundredthSeconds = 0
poResultSet.updateTime(piColIndex, vDateTime)
Case .TIMESTAMP : vDateTime = CreateUnoStruct("com.sun.star.util.DateTime")
vDateTime.Year = Year(pvValue)
vDateTime.Month = Month(pvValue)
vDateTime.Day = Day(pvValue)
vDateTime.Hours = Hour(pvValue)
vDateTime.Minutes = Minute(pvValue)
vDateTime.Seconds = Second(pvValue)
'vDateTime.HundredthSeconds = 0
poResultSet.updateTimestamp(piColIndex, vDateTime)
Case Else
If bNullable Then poResultSet.updateNull(piColIndex)
End Select
End If

End With

_UpdateResultSetColumnValue = True

End Function ' UpdateResultSetColumnValue V 1.6.0
Access2BaseDev Utils _URLEncode Basic   41
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _URLEncode(ByVal psToEncode As String) As String
' http://www.w3schools.com/tags/ref_urlencode.asp
' http://xkr.us/articles/javascript/encode-compare/
' http://tools.ietf.org/html/rfc3986

Dim sEncoded As String, sChar As String
Dim lCurrentChar As Long, bQuestionMark As Boolean

sEncoded = ""
bQuestionMark = False
For lCurrentChar = 1 To Len(psToEncode)
sChar = Mid(psToEncode, lCurrentChar, 1)
Select Case sChar
Case " ", "%"
sEncoded = sEncoded & _PercentEncode(sChar)
Case "?" ' Is it the first "?" ?
If bQuestionMark Then ' "?" introduces in a URL the arguments part
sEncoded = sEncoded & _PercentEncode(sChar)
Else
sEncoded = sEncoded & sChar
bQuestionMark = True
End If
Case "\"
If bQuestionMark Then
sEncoded = sEncoded & _PercentEncode(sChar)
Else
sEncoded = sEncoded & "/" ' If Windows file naming ...
End If
Case Else
If bQuestionMark Then
sEncoded = sEncoded & _PercentEncode(sChar)
Else
sEncoded = sEncoded & _UTF8Encode(sChar) ' Because IE does not support %encoding in first part of URL
End If
End Select
Next lCurrentChar

_URLEncode = sEncoded

End Function ' _URLEncode V1.4.0
Access2BaseDev Utils _UTF8Encode Basic HtmlEncode (Procedure)
_URLEncode (Procedure)
_OutputStringToHTML (Procedure)
23
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _UTF8Encode(ByVal psChar As String) As String
' &-encoding of single psChar character (e.g. "é" becomes "&eacute;" or numeric equivalent
' http://www.w3schools.com/charsets/ref_html_utf8.asp

Select Case psChar
Case """" : _UTF8Encode = """
Case "&" : _UTF8Encode = "&"
Case "<" : _UTF8Encode = "<"
Case ">" : _UTF8Encode = ">"
Case "'" : _UTF8Encode = "'"
Case ":", "/", "?", "#", "[", "]", "@" ' Reserved characters
_UTF8Encode = psChar
Case Chr(13) : _UTF8Encode = "" ' Carriage return
Case Chr(10) : _UTF8Encode = "
"
' Line Feed
Case < Chr(126) : _UTF8Encode = psChar
Case "€" : _UTF8Encode = "&euro;"
Case Else : _UTF8Encode = "&#" & Asc(psChar) & ";"
End Select

Exit Function

End Function ' _UTF8Encode V1.4.0
Standard Module1 DBOpen Basic Access2Base.odb (Database) 5
Sub DBOpen(Optional poEvent As Object)
If GlobalScope.BasicLibraries.hasByName("Access2BaseDev") Then
GlobalScope.BasicLibraries.loadLibrary("Access2BaseDev")
End If
End Sub