update
This commit is contained in:
Jane
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,399 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Collect" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM MODULE NAME <> COLLECTION (is a reserved name for ... collections)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be COLLECTION
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _CollType As String
|
||||
Private _Parent As Object
|
||||
Private _Count As Long
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJCOLLECTION
|
||||
Set _This = Nothing
|
||||
_CollType = ""
|
||||
Set _Parent = Nothing
|
||||
_Count = 0
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Property Get Count() As Long
|
||||
Count = _PropertyGet("Count")
|
||||
End Property ' Count (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Function Item(ByVal Optional pvItem As Variant) As Variant
|
||||
'Return property value.
|
||||
'pvItem either numeric index or property name
|
||||
|
||||
Const cstThisSub = "Collection.getItem"
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvItem) Then Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error
|
||||
Select Case _CollType
|
||||
Case COLLCOMMANDBARCONTROLS ' Have no name
|
||||
If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
Case Else
|
||||
If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
||||
End Select
|
||||
|
||||
Dim vNames() As Variant, oProperty As Object
|
||||
|
||||
Set Item = Nothing
|
||||
Select Case _CollType
|
||||
Case COLLALLDIALOGS
|
||||
Set Item = Application.AllDialogs(pvItem)
|
||||
Case COLLALLFORMS
|
||||
Set Item = Application.AllForms(pvItem)
|
||||
Case COLLALLMODULES
|
||||
Set Item = Application.AllModules(pvItem)
|
||||
Case COLLCOMMANDBARS
|
||||
Set Item = Application.CommandBars(pvItem)
|
||||
Case COLLCOMMANDBARCONTROLS
|
||||
If IsNull(_Parent) Then GoTo Error_Parent
|
||||
Set Item = _Parent.CommandBarControls(pvItem)
|
||||
Case COLLCONTROLS
|
||||
If IsNull(_Parent) Then GoTo Error_Parent
|
||||
Set Item = _Parent.Controls(pvItem)
|
||||
Case COLLFORMS
|
||||
Set Item = Application.Forms(pvItem)
|
||||
Case COLLFIELDS
|
||||
If IsNull(_Parent) Then GoTo Error_Parent
|
||||
Set Item = _Parent.Fields(pvItem)
|
||||
Case COLLPROPERTIES
|
||||
If IsNull(_Parent) Then GoTo Error_Parent
|
||||
Select Case _Parent._Type
|
||||
Case OBJCONTROL, OBJSUBFORM, OBJDATABASE, OBJDIALOG, OBJFIELD _
|
||||
, OBJFORM, OBJQUERYDEF, OBJRECORDSET, OBJTABLEDEF
|
||||
Set Item = _Parent.Properties(pvItem)
|
||||
Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY
|
||||
' NOT SUPPORTED
|
||||
End Select
|
||||
Case COLLQUERYDEFS
|
||||
Set Item = _Parent.QueryDefs(pvItem)
|
||||
Case COLLRECORDSETS
|
||||
Set Item = _Parent.Recordsets(pvItem)
|
||||
Case COLLTABLEDEFS
|
||||
Set Item = _Parent.TableDefs(pvItem)
|
||||
Case COLLTEMPVARS
|
||||
Set Item = Application.TempVars(pvItem)
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
|
||||
Set Item = Nothing
|
||||
GoTo Exit_Function
|
||||
Error_Parent:
|
||||
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, True, Array(_GetLabel("OBJECT"), _GetLabel("PARENT")))
|
||||
Set Item = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' Item V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean
|
||||
' Append a new TableDef or TempVar object to the TableDefs/TempVars collections
|
||||
|
||||
Const cstThisSub = "Collection.Add"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object
|
||||
Dim vObject As Variant, oTempVar As Object
|
||||
Add = False
|
||||
If IsMissing(pvNew) Then Call _TraceArguments()
|
||||
|
||||
Select Case _CollType
|
||||
Case COLLTABLEDEFS
|
||||
If Not Utils._CheckArgument(pvNew, 1, vbObject) Then Goto Exit_Function
|
||||
Set vObject = pvNew
|
||||
With vObject
|
||||
Set odbDatabase = ._ParentDatabase
|
||||
If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
||||
Set oConnection = odbDatabase.Connection
|
||||
If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence
|
||||
Set oTables = oConnection.getTables()
|
||||
oTables.appendByDescriptor(.TableDescriptor)
|
||||
Set .Table = oTables.getByName(._Name)
|
||||
.CatalogName = .Table.CatalogName
|
||||
.SchemaName = .Table.SchemaName
|
||||
.TableName = .Table.Name
|
||||
.TableDescriptor.dispose()
|
||||
Set .TableDescriptor = Nothing
|
||||
.TableFieldsCount = 0
|
||||
.TableKeysCount = 0
|
||||
End With
|
||||
Case COLLTEMPVARS
|
||||
If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function
|
||||
If pvNew = "" Then Goto Error_Name
|
||||
If IsMissing(pvValue) Then Call _TraceArguments()
|
||||
If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name
|
||||
Set oTempVar = New TempVar
|
||||
oTempVar._This = oTempVar
|
||||
oTempVar._Name = pvNew
|
||||
oTempVar._Value = pvValue
|
||||
_A2B_.TempVars.Add(oTempVar, UCase(pvNew))
|
||||
Case Else
|
||||
Goto Error_NotApplicable
|
||||
End Select
|
||||
|
||||
_Count = _Count + 1
|
||||
Add = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
Error_Sequence:
|
||||
TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, vObject._Name)
|
||||
Goto Exit_Function
|
||||
Error_Name:
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew))
|
||||
AddItem = False
|
||||
Goto Exit_Function
|
||||
End Function ' Add V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Delete(ByVal Optional pvName As Variant) As Boolean
|
||||
' Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections
|
||||
|
||||
Const cstThisSub = "Collection.Delete"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Dim odbDatabase As Object, oColl As Object, vName As Variant
|
||||
Delete = False
|
||||
If IsMissing(pvName) Then pvName = ""
|
||||
If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
|
||||
If pvName = "" Then Call _TraceArguments()
|
||||
|
||||
Select Case _CollType
|
||||
Case COLLTABLEDEFS, COLLQUERYDEFS
|
||||
If _A2B_.CurrentDocIndex() <> 0 Then Goto Error_NotApplicable
|
||||
Set odbDatabase = Application._CurrentDb()
|
||||
If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
||||
If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries()
|
||||
With oColl
|
||||
vName = _InList(pvName, .getElementNames(), True)
|
||||
If vName = False Then Goto trace_NotFound
|
||||
.dropByName(vName)
|
||||
End With
|
||||
odbDatabase.Document.store()
|
||||
Case Else
|
||||
Goto Error_NotApplicable
|
||||
End Select
|
||||
|
||||
_Count = _Count - 1
|
||||
Delete = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
Trace_NotFound:
|
||||
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName))
|
||||
Goto Exit_Function
|
||||
End Function ' Delete V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("Collection.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("Collection.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Remove(ByVal Optional pvName As Variant) As Boolean
|
||||
' Remove a TempVar from the TempVars collection
|
||||
|
||||
Const cstThisSub = "Collection.Remove"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Dim oColl As Object, vName As Variant
|
||||
Remove = False
|
||||
If IsMissing(pvName) Then pvName = ""
|
||||
If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
|
||||
If pvName = "" Then Call _TraceArguments()
|
||||
|
||||
Select Case _CollType
|
||||
Case COLLTEMPVARS
|
||||
If Not _A2B_.hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name
|
||||
_A2B_.TempVars.Remove(UCase(pvName))
|
||||
Case Else
|
||||
Goto Error_NotApplicable
|
||||
End Select
|
||||
|
||||
_Count = _Count - 1
|
||||
Remove = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
Error_Name:
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName))
|
||||
AddItem = False
|
||||
Goto Exit_Function
|
||||
End Function ' Remove V1.2.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function RemoveAll() As Boolean
|
||||
' Remove the whole TempVars collection
|
||||
|
||||
Const cstThisSub = "Collection.Remove"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Select Case _CollType
|
||||
Case COLLTEMPVARS
|
||||
Set _A2B_.TempVars = New Collection
|
||||
_Count = 0
|
||||
Case Else
|
||||
Goto Error_NotApplicable
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
End Function ' RemoveAll V1.2.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
_PropertiesList = Array("Count", "Item", "ObjectType")
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Collection.get" & psProperty)
|
||||
_PropertyGet = Nothing
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Count")
|
||||
_PropertyGet = _Count
|
||||
Case UCase("Item")
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Collection.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertyGet = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Collection._PropertyGet", Erl)
|
||||
_PropertyGet = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,396 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="CommandBar" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be COMMANDBAR
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _ResourceURL As String
|
||||
Private _Window As Object ' com.sun.star.frame.XFrame
|
||||
Private _Module As String
|
||||
Private _Toolbar As Object
|
||||
Private _BarBuiltin As Integer ' 1 = builtin, 2 = custom stored in LO/AOO (Base), 3 = custom stored in document (Form)
|
||||
Private _BarType As Integer ' See msoBarTypeXxx constants
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJCOMMANDBAR
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
_ResourceURL = ""
|
||||
Set _Window = Nothing
|
||||
_Module = ""
|
||||
Set _Toolbar = Nothing
|
||||
_BarBuiltin = 0
|
||||
_BarType = -1
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get BuiltIn() As Boolean
|
||||
BuiltIn = _PropertyGet("BuiltIn")
|
||||
End Property ' BuiltIn (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
Public Function pName() As String ' For compatibility with < V0.9.0
|
||||
pName = _PropertyGet("Name")
|
||||
End Function ' pName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Parent() As Object
|
||||
Parent = _Parent
|
||||
End Function ' Parent (get) V6.4.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Visible() As Variant
|
||||
Visible = _PropertyGet("Visible")
|
||||
End Property ' Visible (get)
|
||||
|
||||
Property Let Visible(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Visible", pvValue)
|
||||
End Property ' Visible (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function CommandBarControls(Optional ByVal pvIndex As Variant) As Variant
|
||||
' Return an object of type CommandBarControl indicated by its index
|
||||
' Index is different from UNO index: separators do not count
|
||||
' If no pvIndex argument, return a Collection type
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Const cstThisSub = "CommandBar.CommandBarControls"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim oLayout As Object, vElements() As Variant, iIndexToolbar As Integer, oToolbar As Object
|
||||
Dim i As Integer, iItemsCount As Integer, oSettings As Object, vItem() As Variant, bSeparator As Boolean
|
||||
Dim oObject As Object
|
||||
|
||||
Set oObject = Nothing
|
||||
If Not IsMissing(pvIndex) Then
|
||||
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If pvIndex < 0 Then Goto Trace_IndexError
|
||||
End If
|
||||
|
||||
Select Case _BarType
|
||||
Case msoBarTypeNormal, msoBarTypeMenuBar
|
||||
Case Else : Goto Error_NotApplicable ' Status bar not supported
|
||||
End Select
|
||||
|
||||
Set oLayout = _Window.LayoutManager
|
||||
vElements = oLayout.getElements()
|
||||
iIndexToolbar = _FindElement(vElements())
|
||||
If iIndexToolbar < 0 Then Goto Error_NotApplicable ' Toolbar not visible
|
||||
Set oToolbar = vElements(iIndexToolbar)
|
||||
|
||||
iItemsCount = 0
|
||||
Set oSettings = oToolbar.getSettings(False)
|
||||
|
||||
bSeparator = False
|
||||
For i = 0 To oSettings.getCount() - 1
|
||||
Set vItem() = oSettings.getByIndex(i)
|
||||
If _GetPropertyValue(vItem, "Type", 1) <> 1 Then ' Type = 1 indicates separator
|
||||
iItemsCount = iItemsCount + 1
|
||||
If Not IsMissing(pvIndex) Then
|
||||
If pvIndex = iItemsCount - 1 Then
|
||||
Set oObject = New CommandBarControl
|
||||
With oObject
|
||||
Set ._This = oObject
|
||||
Set ._Parent = _This
|
||||
._ParentCommandBarName = _Name
|
||||
._ParentCommandBar = oToolbar
|
||||
._ParentBuiltin = ( _BarBuiltin = 1 )
|
||||
._Element = vItem()
|
||||
._InternalIndex = i
|
||||
._Index = iItemsCount ' Indexes start at 1
|
||||
._BeginGroup = bSeparator
|
||||
End With
|
||||
End If
|
||||
bSeparator = False
|
||||
End If
|
||||
Else
|
||||
bSeparator = True
|
||||
End If
|
||||
Next i
|
||||
|
||||
If IsNull(oObject) Then
|
||||
Select Case True
|
||||
Case IsMissing(pvIndex)
|
||||
Set oObject = New Collect
|
||||
Set oObject._This = oObject
|
||||
oObject._CollType = COLLCOMMANDBARCONTROLS
|
||||
Set oObject._Parent = _This
|
||||
oObject._Count = iItemsCount
|
||||
Case Else ' pvIndex is numeric
|
||||
Goto Trace_IndexError
|
||||
End Select
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set CommandBarControls = oObject
|
||||
Set oObject = Nothing
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Trace_IndexError:
|
||||
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
End Function ' CommandBarControls V1,3,0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
|
||||
' Alias for CommandBarControls (VBA)
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Const cstThisSub = "CommandBar.Controls"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim oObject As Object
|
||||
|
||||
If IsMissing(pvIndex) Then Set oObject = CommandBarControls() Else Set oObject = CommandBarControls(pvIndex)
|
||||
|
||||
Exit_Function:
|
||||
Set Controls = oObject
|
||||
Set oObject = Nothing
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Controls V1,3,0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("CommandBar.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("CommandBar.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Reset() As Boolean
|
||||
' Reset a whole command bar to its initial values
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Const cstThisSub = "CommandBar.Reset"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
_Toolbar.reload()
|
||||
|
||||
Exit_Function:
|
||||
Reset = True
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
Reset = False
|
||||
GoTo Exit_Function
|
||||
End Function ' Reset V1.3.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _FindElement(pvElements As Variant) As Integer
|
||||
' Return -1 if not found, otherwise return index in elements table of LayoutManager
|
||||
|
||||
Dim i As Integer
|
||||
|
||||
_FindElement = -1
|
||||
If Not IsArray(pvElements) Then Exit Function
|
||||
|
||||
For i = 0 To UBound(pvElements)
|
||||
If _ResourceURL = pvElements(i).ResourceURL Then
|
||||
_FindElement = i
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
_PropertiesList = Array("BuiltIn", "Name", "ObjectType", "Visible")
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = "CommandBar.get" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
_PropertyGet = Nothing
|
||||
|
||||
Dim oLayout As Object, iElementIndex As Integer
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("BuiltIn")
|
||||
_PropertyGet = ( _BarBuiltin = 1 )
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Visible")
|
||||
Set oLayout = _Window.LayoutManager
|
||||
iElementIndex = _FindElement(oLayout.getElements())
|
||||
If iElementIndex < 0 Then _PropertyGet = False Else _PropertyGet = oLayout.isElementVisible(_ResourceURL)
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
|
||||
_PropertyGet = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = "CommandBar.set" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
_PropertySet = True
|
||||
Dim iArgNr As Integer
|
||||
Dim oLayout As Object, iElementIndex As Integer
|
||||
|
||||
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("setProperty") : iArgNr = 3
|
||||
Case UCase("CommandBar.setProperty") : iArgNr = 2
|
||||
Case UCase(cstThisSub) : iArgNr = 1
|
||||
End Select
|
||||
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Visible")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
Set oLayout = _Window.LayoutManager
|
||||
With oLayout
|
||||
iElementIndex = _FindElement(.getElements())
|
||||
If iElementIndex < 0 Then
|
||||
If pvValue Then
|
||||
.createElement(_ResourceURL)
|
||||
.showElement(_ResourceURL)
|
||||
End If
|
||||
Else
|
||||
If pvValue <> .isElementVisible(_ResourceURL) Then
|
||||
If pvValue Then .showElement(_ResourceURL) Else .hideElement(_ResourceURL)
|
||||
End If
|
||||
End If
|
||||
End With
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,339 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="CommandBarControl" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be COMMANDBARCONTROL
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _InternalIndex As Integer ' Index in toolbar including separators
|
||||
Private _Index As Integer ' Index in collection, starting at 1 !!
|
||||
Private _ControlType As Integer ' 1 of the msoControl* constants
|
||||
Private _ParentCommandBarName As String
|
||||
Private _ParentCommandBar As Object ' com.sun.star.ui.XUIElement
|
||||
Private _ParentBuiltin As Boolean
|
||||
Private _Element As Variant
|
||||
Private _BeginGroup As Boolean
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJCOMMANDBARCONTROL
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Index = -1
|
||||
_ParentCommandBarName = ""
|
||||
Set _ParentCommandBar = Nothing
|
||||
_ParentBuiltin = False
|
||||
_Element = Array()
|
||||
_BeginGroup = False
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get BeginGroup() As Boolean
|
||||
BeginGroup = _PropertyGet("BeginGroup")
|
||||
End Property ' BeginGroup (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get BuiltIn() As Boolean
|
||||
BuiltIn = _PropertyGet("BuiltIn")
|
||||
End Property ' BuiltIn (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Caption() As Variant
|
||||
Caption = _PropertyGet("Caption")
|
||||
End Property ' Caption (get)
|
||||
|
||||
Property Let Caption(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Caption", pvValue)
|
||||
End Property ' Caption (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Index() As Integer
|
||||
Index = _PropertyGet("Index")
|
||||
End Property ' Index (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnAction() As Variant
|
||||
OnAction = _PropertyGet("OnAction")
|
||||
End Property ' OnAction (get)
|
||||
|
||||
Property Let OnAction(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnAction", pvValue)
|
||||
End Property ' OnAction (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Parent() As Object
|
||||
Parent = _PropertyGet("Parent")
|
||||
End Property ' Parent (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get TooltipText() As Variant
|
||||
TooltipText = _PropertyGet("TooltipText")
|
||||
End Property ' TooltipText (get)
|
||||
|
||||
Property Let TooltipText(ByVal pvValue As Variant)
|
||||
Call _PropertySet("TooltipText", pvValue)
|
||||
End Property ' TooltipText (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function pType() As Integer
|
||||
pType = _PropertyGet("Type")
|
||||
End Function ' Type (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Visible() As Variant
|
||||
Visible = _PropertyGet("Visible")
|
||||
End Property ' Visible (get)
|
||||
|
||||
Property Let Visible(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Visible", pvValue)
|
||||
End Property ' Visible (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Execute()
|
||||
' Execute the command stored in a toolbar button
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Const cstThisSub = "CommandBarControl.Execute"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim sExecute As String
|
||||
|
||||
Execute = True
|
||||
sExecute = _GetPropertyValue(_Element, "CommandURL", "")
|
||||
|
||||
Select Case True
|
||||
Case sExecute = "" : Execute = False
|
||||
Case _IsLeft(sExecute, ".uno:")
|
||||
Execute = DoCmd.RunCommand(sExecute)
|
||||
Case _IsLeft(sExecute, "vnd.sun.star.script:")
|
||||
Execute = Utils._RunScript(sExecute, Array(Nothing))
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
Execute = False
|
||||
GoTo Exit_Function
|
||||
End Function ' Execute V1.3.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("CommandBarControl.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("CommandBar.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
_PropertiesList = Array("BeginGroup", "BuiltIn", "Caption", "Index" _
|
||||
, "ObjectType", "OnAction", "Parent" _
|
||||
, "TooltipText", "Type", "Visible" _
|
||||
)
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = "CommandBarControl.get" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
_PropertyGet = Null
|
||||
|
||||
Dim oLayout As Object, iElementIndex As Integer
|
||||
Dim sValue As String
|
||||
Const cstUnoPrefix = ".uno:"
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("BeginGroup")
|
||||
_PropertyGet = _BeginGroup
|
||||
Case UCase("BuiltIn")
|
||||
sValue = _GetPropertyValue(_Element, "CommandURL", "")
|
||||
_PropertyGet = ( _IsLeft(sValue, cstUnoPrefix) )
|
||||
Case UCase("Caption")
|
||||
_PropertyGet = _GetPropertyValue(_Element, "Label", "")
|
||||
Case UCase("Index")
|
||||
_PropertyGet = _Index
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("OnAction")
|
||||
_PropertyGet = _GetPropertyValue(_Element, "CommandURL", "")
|
||||
Case UCase("Parent")
|
||||
Set _PropertyGet = _Parent
|
||||
Case UCase("TooltipText")
|
||||
sValue = _GetPropertyValue(_Element, "Tooltip", "")
|
||||
If sValue <> "" Then _PropertyGet = sValue Else _PropertyGet = _GetPropertyValue(_Element, "Label", "")
|
||||
Case UCase("Type")
|
||||
_PropertyGet = msoControlButton
|
||||
Case UCase("Visible")
|
||||
_PropertyGet = _GetPropertyValue(_Element, "IsVisible", "")
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
|
||||
_PropertyGet = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = "CommandBarControl.set" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
_PropertySet = True
|
||||
Dim iArgNr As Integer
|
||||
Dim oSettings As Object, sValue As String
|
||||
|
||||
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("setProperty") : iArgNr = 3
|
||||
Case UCase("CommandBar.setProperty") : iArgNr = 2
|
||||
Case UCase(cstThisSub) : iArgNr = 1
|
||||
End Select
|
||||
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
If _ParentBuiltin Then Goto Trace_Error ' Modifications of individual controls forbidden for builtin toolbars (design choice)
|
||||
|
||||
Const cstUnoPrefix = ".uno:"
|
||||
Const cstScript = "vnd.sun.star.script:"
|
||||
|
||||
Set oSettings = _ParentCommandBar.getSettings(True)
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("OnAction")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, _AddNumeric(vbString), , False) Then Goto Trace_Error_Value
|
||||
Select Case VarType(pvValue)
|
||||
Case vbString
|
||||
If _IsLeft(pvValue, cstUnoPrefix) Then
|
||||
sValue = pvValue
|
||||
ElseIf _IsLeft(pvValue, cstScript) Then
|
||||
sValue = pvValue
|
||||
Else
|
||||
sValue = DoCmd.RunCommand(pvValue, True)
|
||||
End If
|
||||
Case Else ' Numeric
|
||||
sValue = DoCmd.RunCommand(pvValue, True)
|
||||
End Select
|
||||
_SetPropertyValue(_Element, "CommandURL", sValue)
|
||||
Case UCase("TooltipText")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
_SetPropertyValue(_Element, "Tooltip", pvValue)
|
||||
Case UCase("Visible")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
_SetPropertyValue(_Element, "IsVisible", pvValue)
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
oSettings.replaceByIndex(_InternalIndex, _Element)
|
||||
_ParentCommandBar.setSettings(oSettings)
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,598 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="DataDef" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be TABLEDEF or QUERYDEF
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String ' For tables: [[Catalog.]Schema.]Table
|
||||
Private _ParentDatabase As Object
|
||||
Private _ReadOnly As Boolean
|
||||
Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable
|
||||
Private CatalogName As String
|
||||
Private SchemaName As String
|
||||
Private TableName As String
|
||||
Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery
|
||||
Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable
|
||||
Private TableFieldsCount As Integer
|
||||
Private TableKeysCount As Integer
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = ""
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
Set _ParentDatabase = Nothing
|
||||
_ReadOnly = False
|
||||
Set Table = Nothing
|
||||
CatalogName = ""
|
||||
SchemaName = ""
|
||||
TableName = ""
|
||||
Set Query = Nothing
|
||||
Set TableDescriptor = Nothing
|
||||
TableFieldsCount = 0
|
||||
TableKeysCount = 0
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get SQL() As Variant
|
||||
SQL = _PropertyGet("SQL")
|
||||
End Property ' SQL (get)
|
||||
|
||||
Property Let SQL(ByVal pvValue As Variant)
|
||||
Call _PropertySet("SQL", pvValue)
|
||||
End Property ' SQL (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function pType() As Integer
|
||||
pType = _PropertyGet("Type")
|
||||
End Function ' Type (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function CreateField(ByVal Optional pvFieldName As Variant _
|
||||
, ByVal optional pvType As Variant _
|
||||
, ByVal optional pvSize As Variant _
|
||||
, ByVal optional pvAttributes As Variant _
|
||||
) As Object
|
||||
'Return a Field object
|
||||
Const cstThisSub = "TableDef.CreateField"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object
|
||||
Const cstMaxKeyLength = 30
|
||||
|
||||
CreateField = Nothing
|
||||
If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
||||
If IsMissing(pvFieldName) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function
|
||||
If pvFieldName = "" Then Call _TraceArguments()
|
||||
If IsMissing(pvType) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _
|
||||
dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _
|
||||
, dbNumeric, dbDecimal, dbText, dbChar, dbMemo _
|
||||
, dbDate, dbTime, dbTimeStamp _
|
||||
, dbBinary, dbVarBinary, dbLongBinary, dbBoolean _
|
||||
)) Then Goto Exit_Function
|
||||
If IsMissing(pvSize) Then pvSize = 0
|
||||
If pvSize < 0 Then pvSize = 0
|
||||
If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If IsMissing(pvAttributes) Then pvAttributes = 0
|
||||
If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function
|
||||
|
||||
If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable
|
||||
If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable
|
||||
|
||||
If _ReadOnly Then Goto Error_NoUpdate
|
||||
|
||||
Set oNewField = New Field
|
||||
With oNewField
|
||||
._This = oNewField
|
||||
._Name = pvFieldName
|
||||
._ParentName = _Name
|
||||
._ParentType = OBJTABLEDEF
|
||||
If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table
|
||||
Set .Column = oTable.Columns.createDataDescriptor()
|
||||
End With
|
||||
With oNewField.Column
|
||||
.Name = pvFieldName
|
||||
Select Case pvType
|
||||
Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT
|
||||
Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER
|
||||
Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT
|
||||
Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT
|
||||
Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL
|
||||
Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE
|
||||
Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC
|
||||
Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL
|
||||
Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR
|
||||
Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR
|
||||
Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR
|
||||
Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE
|
||||
Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME
|
||||
Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP
|
||||
Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY
|
||||
Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY
|
||||
Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY
|
||||
Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN
|
||||
End Select
|
||||
.Precision = Int(pvSize)
|
||||
If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10
|
||||
.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
|
||||
If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName
|
||||
If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName
|
||||
If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName
|
||||
If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1
|
||||
If pvAttributes = dbAutoIncrField Then
|
||||
If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists
|
||||
Set oKeys = oTable.Keys
|
||||
Set oPrimaryKey = oKeys.createDataDescriptor()
|
||||
Set oColumn = oPrimaryKey.Columns.createDataDescriptor()
|
||||
oColumn.Name = pvFieldName
|
||||
oColumn.CatalogName = CatalogName
|
||||
oColumn.SchemaName = SchemaName
|
||||
oColumn.TableName = TableName
|
||||
oColumn.IsAutoIncrement = True
|
||||
oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
|
||||
oPrimaryKey.Columns.appendByDescriptor(oColumn)
|
||||
oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength)
|
||||
oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY
|
||||
oKeys.appendByDescriptor(oPrimaryKey)
|
||||
.IsAutoIncrement = True
|
||||
.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
|
||||
oColumn.dispose()
|
||||
Else
|
||||
.IsAutoIncrement = False
|
||||
End If
|
||||
End With
|
||||
oTable.Columns.appendByDescriptor(oNewfield.Column)
|
||||
|
||||
Set CreateField = oNewField
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
Error_Sequence:
|
||||
TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName)
|
||||
Goto Exit_Function
|
||||
Error_NoUpdate:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
End Function ' CreateField V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean
|
||||
'Execute a stored query. The query must be an ACTION query.
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".Execute"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
On Local Error Goto Error_Function
|
||||
Const cstNull = -1
|
||||
Execute = False
|
||||
If _Type <> OBJQUERYDEF Then Goto Trace_Method
|
||||
If IsMissing(pvOptions) Then
|
||||
pvOptions = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
|
||||
End If
|
||||
|
||||
'Check action query
|
||||
Dim oStatement As Object, vResult As Variant
|
||||
Dim iType As Integer, sSql As String
|
||||
iType = pType
|
||||
If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action
|
||||
|
||||
'Execute action query
|
||||
Set oStatement = _ParentDatabase.Connection.createStatement()
|
||||
sSql = Query.Command
|
||||
If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _
|
||||
Else oStatement.EscapeProcessing = Query.EscapeProcessing
|
||||
On Local Error Goto SQL_Error
|
||||
vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql))
|
||||
On Local Error Goto Error_Function
|
||||
|
||||
Execute = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Method:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub)
|
||||
Goto Exit_Function
|
||||
Trace_Action:
|
||||
TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name)
|
||||
Goto Exit_Function
|
||||
SQL_Error:
|
||||
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Execute V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Fields(ByVal Optional pvIndex As Variant) As Object
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".Fields"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Set Fields = Nothing
|
||||
If Not IsMissing(pvIndex) Then
|
||||
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
||||
End If
|
||||
|
||||
Dim sObjects() As String, sObjectName As String, oObject As Object
|
||||
Dim i As Integer, bFound As Boolean, oFields As Object
|
||||
|
||||
If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns()
|
||||
sObjects = oFields.ElementNames()
|
||||
Select Case True
|
||||
Case IsMissing(pvIndex)
|
||||
Set oObject = New Collect
|
||||
Set oObject._This = oObject
|
||||
oObject._CollType = COLLFIELDS
|
||||
Set oObject._Parent = _This
|
||||
oObject._Count = UBound(sObjects) + 1
|
||||
Goto Exit_Function
|
||||
Case VarType(pvIndex) = vbString
|
||||
bFound = False
|
||||
' Check existence of object and find its exact (case-sensitive) name
|
||||
For i = 0 To UBound(sObjects)
|
||||
If UCase(pvIndex) = UCase(sObjects(i)) Then
|
||||
sObjectName = sObjects(i)
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
If Not bFound Then Goto Trace_NotFound
|
||||
Case Else ' pvIndex is numeric
|
||||
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
|
||||
sObjectName = sObjects(pvIndex)
|
||||
End Select
|
||||
|
||||
Set oObject = New Field
|
||||
Set oObject._This = oObject
|
||||
oObject._Name = sObjectName
|
||||
Set oObject.Column = oFields.getByName(sObjectName)
|
||||
oObject._ParentName = _Name
|
||||
oObject._ParentType = _Type
|
||||
Set oObject._ParentDatabase = _ParentDatabase
|
||||
|
||||
Exit_Function:
|
||||
Set Fields = oObject
|
||||
Set oObject = Nothing
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Trace_NotFound:
|
||||
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex))
|
||||
Goto Exit_Function
|
||||
Trace_IndexError:
|
||||
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
End Function ' Fields
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".getProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".hasProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object
|
||||
'Return a Recordset object based on current table- or querydef object
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".OpenRecordset"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
Const cstNull = -1
|
||||
Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean
|
||||
Dim iType As Integer, iOptions As Integer, iLockEdit As Integer
|
||||
|
||||
|
||||
Set oObject = Nothing
|
||||
If VarType(pvType) = vbError Then
|
||||
iType = cstNull
|
||||
ElseIf IsMissing(pvType) Then
|
||||
iType = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
|
||||
iType = pvType
|
||||
End If
|
||||
If VarType(pvOptions) = vbError Then
|
||||
iOptions = cstNull
|
||||
ElseIf IsMissing(pvOptions) Then
|
||||
iOptions = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
|
||||
iOptions = pvOptions
|
||||
End If
|
||||
If VarType(pvLockEdit) = vbError Then
|
||||
iLockEdit = cstNull
|
||||
ElseIf IsMissing(pvLockEdit) Then
|
||||
iLockEdit = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
|
||||
iLockEdit = pvLockEdit
|
||||
End If
|
||||
|
||||
Select Case _Type
|
||||
Case OBJTABLEDEF
|
||||
lCommandType = com.sun.star.sdb.CommandType.TABLE
|
||||
sCommand = _Name
|
||||
Case OBJQUERYDEF
|
||||
lCommandType = com.sun.star.sdb.CommandType.QUERY
|
||||
sCommand = _Name
|
||||
If iOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing
|
||||
End Select
|
||||
|
||||
Set oObject = New Recordset
|
||||
With oObject
|
||||
._CommandType = lCommandType
|
||||
._Command = sCommand
|
||||
._ParentName = _Name
|
||||
._ParentType = _Type
|
||||
._ForwardOnly = ( iType = dbOpenForwardOnly )
|
||||
._PassThrough = bPassThrough
|
||||
._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly )
|
||||
Set ._ParentDatabase = _ParentDatabase
|
||||
Set ._This = oObject
|
||||
Call ._Initialize()
|
||||
End With
|
||||
With _ParentDatabase
|
||||
.RecordsetMax = .RecordsetMax + 1
|
||||
oObject._Name = Format(.RecordsetMax, "0000000")
|
||||
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
|
||||
End With
|
||||
|
||||
If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty
|
||||
|
||||
Exit_Function:
|
||||
Set OpenRecordset = oObject
|
||||
Set oObject = Nothing
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
Set oObject = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' OpenRecordset V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".Properties"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
Set vProperty._ParentDatabase = _ParentDatabase
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".setProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
Select Case _Type
|
||||
Case OBJTABLEDEF
|
||||
_PropertiesList = Array("Name", "ObjectType")
|
||||
Case OBJQUERYDEF
|
||||
_PropertiesList = Array("Name", "ObjectType", "SQL", "Type")
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type)
|
||||
Utils._SetCalledSub(cstThisSub & ".get" & psProperty)
|
||||
Dim sSql As String, sVerb As String, iType As Integer
|
||||
_PropertyGet = EMPTY
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("SQL")
|
||||
_PropertyGet = Query.Command
|
||||
Case UCase("Type")
|
||||
iType = 0
|
||||
sSql = Utils._Trim(UCase(Query.Command))
|
||||
sVerb = Split(sSql, " ")(0)
|
||||
If sVerb = "SELECT" Then iType = iType + dbQSelect
|
||||
If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 _
|
||||
Or sVerb = "CREATE" And InStr(sSql, " TABLE ") > 0 _
|
||||
Then iType = iType + dbQMakeTable
|
||||
If sVerb = "SELECT" And InStr(sSql, " UNION ") > 0 Then iType = iType + dbQSetOperation
|
||||
If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough
|
||||
If sVerb = "INSERT" Then iType = iType + dbQAppend
|
||||
If sVerb = "DELETE" Then iType = iType + dbQDelete
|
||||
If sVerb = "UPDATE" Then iType = iType + dbQUpdate
|
||||
If sVerb = "CREATE" _
|
||||
Or sVerb = "ALTER" _
|
||||
Or sVerb = "DROP" _
|
||||
Or sVerb = "RENAME" _
|
||||
Or sVerb = "TRUNCATE" _
|
||||
Then iType = iType + dbQDDL
|
||||
' dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate
|
||||
' To check Type use: If (iType And dbQxxx) <> 0 Then ...
|
||||
_PropertyGet = iType
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub & ".get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type)
|
||||
Utils._SetCalledSub(cstThisSub & ".set" & psProperty)
|
||||
|
||||
'Execute
|
||||
Dim iArgNr As Integer
|
||||
|
||||
_PropertySet = True
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("setProperty") : iArgNr = 3
|
||||
Case UCase(cstThisSub & ".setProperty") : iArgNr = 2
|
||||
Case UCase(cstThisSub & ".set" & psProperty) : iArgNr = 1
|
||||
End Select
|
||||
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
If _ReadOnly Then Goto Error_NoUpdate
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("SQL")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
Query.Command = pvValue
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub & ".set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_NoUpdate:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,818 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Dialog" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be DIALOG
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _Shortcut As String
|
||||
Private _Dialog As Object ' com.sun.star.io.XInputStreamProvider
|
||||
Private _Storage As String ' GLOBAL or DOCUMENT
|
||||
Private _Library As String
|
||||
Private UnoDialog As Object ' com.sun.star.awt.XControl
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJDIALOG
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
Set _Dialog = Nothing
|
||||
_Storage = ""
|
||||
_Library = ""
|
||||
Set UnoDialog = Nothing
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Caption() As Variant
|
||||
Caption = _PropertyGet("Caption")
|
||||
End Property ' Caption (get)
|
||||
|
||||
Property Let Caption(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Caption", pvValue)
|
||||
End Property ' Caption (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Height() As Variant
|
||||
Height = _PropertyGet("Height")
|
||||
End Property ' Height (get)
|
||||
|
||||
Property Let Height(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Height", pvValue)
|
||||
End Property ' Height (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get IsLoaded() As Boolean
|
||||
IsLoaded = _PropertyGet("IsLoaded")
|
||||
End Property
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
Public Function pName() As String ' For compatibility with < V0.9.0
|
||||
pName = _PropertyGet("Name")
|
||||
End Function ' pName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnFocusGained() As Variant
|
||||
OnFocusGained = _PropertyGet("OnFocusGained")
|
||||
End Property ' OnFocusGained (get)
|
||||
|
||||
Property Let OnFocusGained(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnFocusGained", pvValue)
|
||||
End Property ' OnFocusGained (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnFocusLost() As Variant
|
||||
OnFocusLost = _PropertyGet("OnFocusLost")
|
||||
End Property ' OnFocusLost (get)
|
||||
|
||||
Property Let OnFocusLost(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnFocusLost", pvValue)
|
||||
End Property ' OnFocusLost (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnKeyPressed() As Variant
|
||||
OnKeyPressed = _PropertyGet("OnKeyPressed")
|
||||
End Property ' OnKeyPressed (get)
|
||||
|
||||
Property Let OnKeyPressed(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnKeyPressed", pvValue)
|
||||
End Property ' OnKeyPressed (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnKeyReleased() As Variant
|
||||
OnKeyReleased = _PropertyGet("OnKeyReleased")
|
||||
End Property ' OnKeyReleased (get)
|
||||
|
||||
Property Let OnKeyReleased(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnKeyReleased", pvValue)
|
||||
End Property ' OnKeyReleased (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnMouseDragged() As Variant
|
||||
OnMouseDragged = _PropertyGet("OnMouseDragged")
|
||||
End Property ' OnMouseDragged (get)
|
||||
|
||||
Property Let OnMouseDragged(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnMouseDragged", pvValue)
|
||||
End Property ' OnMouseDragged (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnMouseEntered() As Variant
|
||||
OnMouseEntered = _PropertyGet("OnMouseEntered")
|
||||
End Property ' OnMouseEntered (get)
|
||||
|
||||
Property Let OnMouseEntered(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnMouseEntered", pvValue)
|
||||
End Property ' OnMouseEntered (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnMouseExited() As Variant
|
||||
OnMouseExited = _PropertyGet("OnMouseExited")
|
||||
End Property ' OnMouseExited (get)
|
||||
|
||||
Property Let OnMouseExited(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnMouseExited", pvValue)
|
||||
End Property ' OnMouseExited (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnMouseMoved() As Variant
|
||||
OnMouseMoved = _PropertyGet("OnMouseMoved")
|
||||
End Property ' OnMouseMoved (get)
|
||||
|
||||
Property Let OnMouseMoved(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnMouseMoved", pvValue)
|
||||
End Property ' OnMouseMoved (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnMousePressed() As Variant
|
||||
OnMousePressed = _PropertyGet("OnMousePressed")
|
||||
End Property ' OnMousePressed (get)
|
||||
|
||||
Property Let OnMousePressed(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnMousePressed", pvValue)
|
||||
End Property ' OnMousePressed (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnMouseReleased() As Variant
|
||||
OnMouseReleased = _PropertyGet("OnMouseReleased")
|
||||
End Property ' OnMouseReleased (get)
|
||||
|
||||
Property Let OnMouseReleased(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnMouseReleased", pvValue)
|
||||
End Property ' OnMouseReleased (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant
|
||||
' Return either an error or an object of type OPTIONGROUP based on its name
|
||||
' A group is determined by the successive TabIndexes of the radio button
|
||||
' The name of the group = the name of its first element
|
||||
|
||||
Utils._SetCalledSub("Dialog.OptionGroup")
|
||||
If IsMissing(pvGroupName) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Set OptionGroup = Nothing
|
||||
If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function
|
||||
|
||||
Dim iAllCount As Integer, iRadioLast As Integer, iGroupCount As Integer, iBegin As Integer, iEnd As Integer
|
||||
Dim oRadios() As Object, sGroupName As String
|
||||
Dim i As Integer, j As Integer, bFound As Boolean, ocControl As Object, oRadio As Object, iTabIndex As Integer
|
||||
Dim ogGroup As Object, vGroup() As Variant, vIndex() As Variant
|
||||
iAllCount = Controls.Count
|
||||
If iAllCount > 0 Then
|
||||
iRadioLast = -1
|
||||
ReDim oRadios(0 To iAllCount - 1)
|
||||
For i = 0 To iAllCount - 1 ' Store all RadioButtons objects
|
||||
Set ocControl = Controls(i)
|
||||
If ocControl._SubType = CTLRADIOBUTTON Then
|
||||
iRadioLast = iRadioLast + 1
|
||||
Set oRadios(iRadioLast) = ocControl
|
||||
End If
|
||||
Next i
|
||||
Else
|
||||
Goto Error_Arg ' No control in dialog
|
||||
End If
|
||||
|
||||
If iRadioLast < 0 then Goto Error_Arg ' No radio buttons in the dialog
|
||||
|
||||
'Resort oRadio array based on tab indexes
|
||||
If iRadioLast > 0 Then
|
||||
For i = 0 To iRadioLast - 1 ' Bubble sort
|
||||
For j = i + 1 To iRadioLast
|
||||
If oRadios(i).TabIndex > oRadios(j).TabIndex Then
|
||||
Set oRadio = oRadios(i)
|
||||
Set oRadios(i) = oRadios(j)
|
||||
Set oRadios(j) = oRadio
|
||||
End If
|
||||
Next j
|
||||
Next i
|
||||
End If
|
||||
|
||||
'Scan Names to find match with argument
|
||||
bFound = False
|
||||
For i = 0 To iRadioLast
|
||||
If UCase(oRadios(i)._Name) = UCase(pvGroupName) Then
|
||||
Select Case i
|
||||
Case 0 : bFound = True
|
||||
Case Else
|
||||
If oRadios(i).TabIndex > oRadios(i - 1).TabIndex + 1 Then
|
||||
bFound = True
|
||||
Else
|
||||
Goto Error_Arg ' same group as preceding item although name correct
|
||||
End If
|
||||
End Select
|
||||
If bFound Then
|
||||
iBegin = i
|
||||
iEnd = i
|
||||
sGroupName = oRadios(i)._Name
|
||||
End If
|
||||
ElseIf bFound Then
|
||||
If oRadios(i).TabIndex = oRadios(i - 1).TabIndex + 1 Then iEnd = i
|
||||
End If
|
||||
Next i
|
||||
|
||||
If bFound Then ' Create OptionGroup
|
||||
iGroupCount = iEnd - iBegin + 1
|
||||
Set ogGroup = New OptionGroup
|
||||
ReDim vGroup(0 To iGroupCount - 1)
|
||||
ReDim vIndex(0 To iGroupCount - 1)
|
||||
With ogGroup
|
||||
._This = ogGroup
|
||||
._Name = sGroupName
|
||||
._Count = iGroupCount
|
||||
._ButtonsGroup = vGroup
|
||||
._ButtonsIndex = vIndex
|
||||
For i = 0 To iGroupCount - 1
|
||||
Set ._ButtonsGroup(i) = oRadios(iBegin + i).ControlModel
|
||||
._ButtonsIndex(i) = i
|
||||
Next i
|
||||
._ParentType = CTLPARENTISDIALOG
|
||||
._ParentComponent = UnoDialog
|
||||
End With
|
||||
Else Goto Error_Arg
|
||||
End If
|
||||
|
||||
Set OptionGroup = ogGroup
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.OptionGroup")
|
||||
Exit Function
|
||||
Error_Arg:
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName))
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog.OptionGroup", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' OptionGroup V0.9.1
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Page() As Variant
|
||||
Page = _PropertyGet("Page")
|
||||
End Property ' Page (get)
|
||||
|
||||
Property Let Page(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Page", pvValue)
|
||||
End Property ' Page (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Parent() As Object
|
||||
Parent = _Parent
|
||||
End Function ' Parent (get) V6.4.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Const cstThisSub = "Dialog.Properties"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Visible() As Variant
|
||||
Visible = _PropertyGet("Visible")
|
||||
End Property ' Visible (get)
|
||||
|
||||
Property Let Visible(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Visible", pvValue)
|
||||
End Property ' Visible (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Width() As Variant
|
||||
Width = _PropertyGet("Width")
|
||||
End Property ' Width (get)
|
||||
|
||||
Property Let Width(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Width", pvValue)
|
||||
End Property ' Width (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
|
||||
' Return a Control object with name or index = pvIndex
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Dialog.Controls")
|
||||
|
||||
Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer
|
||||
Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String
|
||||
Dim j As Integer
|
||||
|
||||
Set ocControl = Nothing
|
||||
If Not IsLoaded Then Goto Trace_Error_NotOpen
|
||||
Set ocControl = New Control
|
||||
Set ocControl._This = ocControl
|
||||
Set ocControl._Parent = _This
|
||||
ocControl._ParentType = CTLPARENTISDIALOG
|
||||
sParentShortcut = _Shortcut
|
||||
sControls() = UnoDialog.Model.getElementNames()
|
||||
iControlCount = UBound(sControls) + 1
|
||||
|
||||
If IsMissing(pvIndex) Then ' No argument, return Collection object
|
||||
Set oCounter = New Collect
|
||||
Set oCounter._This = oCounter
|
||||
oCounter._CollType = COLLCONTROLS
|
||||
oCounter._Count = iControlCount
|
||||
Set oCounter._Parent = _This
|
||||
Set Controls = oCounter
|
||||
Goto Exit_Function
|
||||
End If
|
||||
|
||||
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
||||
|
||||
' Start building the ocControl object
|
||||
' Determine exact name
|
||||
|
||||
Select Case VarType(pvIndex)
|
||||
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
|
||||
If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index
|
||||
ocControl._Name = sControls(pvIndex)
|
||||
Case vbString ' Check control name validity (non case sensitive)
|
||||
bFound = False
|
||||
sIndex = UCase(Utils._Trim(pvIndex))
|
||||
For i = 0 To iControlCount - 1
|
||||
If UCase(sControls(i)) = sIndex Then
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound
|
||||
End Select
|
||||
|
||||
ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name)
|
||||
Set ocControl.ControlModel = UnoDialog.Model.getByName(ocControl._Name)
|
||||
Set ocControl.ControlView = UnoDialog.getControl(ocControl._Name)
|
||||
ocControl._ImplementationName = ocControl.ControlModel.getImplementationName()
|
||||
ocControl._FormComponent = UnoDialog
|
||||
|
||||
ocControl._Initialize()
|
||||
Set Controls = ocControl
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.Controls")
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex))
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Trace_Error_NotOpen:
|
||||
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, , _Name)
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Trace_Error_Index:
|
||||
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Trace_NotFound:
|
||||
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, pvIndex))
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog.Controls", Erl)
|
||||
Set Controls = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' Controls
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub EndExecute(ByVal Optional pvReturn As Variant)
|
||||
' Stop executing the dialog
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Sub
|
||||
Utils._SetCalledSub("Dialog.endExecute")
|
||||
|
||||
If IsMissing(pvReturn) Then pvReturn = 0
|
||||
If Not Utils._CheckArgument(pvReturn, 1, Utils._AddNumeric(), , False) Then Goto Trace_Error
|
||||
|
||||
Dim lExecute As Long
|
||||
lExecute = CLng(pvReturn)
|
||||
If IsNull(_Dialog) Then Goto Error_Execute
|
||||
If IsNull(UnoDialog) Then Goto Error_Not_Started
|
||||
Call UnoDialog.endDialog(lExecute)
|
||||
|
||||
Exit_Sub:
|
||||
Utils._ResetCalledSub("Dialog.endExecute")
|
||||
Exit Sub
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array("1", Utils._CStr(pvReturn)))
|
||||
Goto Exit_Sub
|
||||
Error_Execute:
|
||||
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
|
||||
Goto Exit_Sub
|
||||
Error_Not_Started:
|
||||
TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
|
||||
Goto Exit_Sub
|
||||
Error_Sub:
|
||||
TraceError(TRACEABORT, Err, "Dialog.endExecute", Erl)
|
||||
GoTo Exit_Sub
|
||||
End Sub ' EndExecute
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Execute() As Long
|
||||
' Execute dialog
|
||||
|
||||
'If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
'Seems smart not to trap errors: debugging of dialog events otherwise made very difficult !
|
||||
Utils._SetCalledSub("Dialog.Execute")
|
||||
|
||||
Dim lExecute As Long
|
||||
If IsNull(_Dialog) Then Goto Error_Execute
|
||||
If IsNull(UnoDialog) Then Goto Error_Not_Started
|
||||
lExecute = UnoDialog.execute()
|
||||
|
||||
Select Case lExecute
|
||||
Case 1 : Execute = dlgOK
|
||||
Case 0 : Execute = dlgCancel
|
||||
Case Else : Execute = lExecute
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.Execute")
|
||||
Exit Function
|
||||
Error_Execute:
|
||||
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_Not_Started:
|
||||
TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog.Execute", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Execute
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("Dialog.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("Dialog.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Move( ByVal Optional pvLeft As Variant _
|
||||
, ByVal Optional pvTop As Variant _
|
||||
, ByVal Optional pvWidth As Variant _
|
||||
, ByVal Optional pvHeight As Variant _
|
||||
) As Variant
|
||||
' Execute Move method
|
||||
Utils._SetCalledSub("Dialog.Move")
|
||||
On Local Error Goto Error_Function
|
||||
Move = False
|
||||
Dim iArgNr As Integer
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("Move") : iArgNr = 1
|
||||
Case UCase("Dialog.Move") : iArgNr = 0
|
||||
End Select
|
||||
If IsMissing(pvLeft) Then pvLeft = -1
|
||||
If IsMissing(pvTop) Then pvTop = -1
|
||||
If IsMissing(pvWidth) Then pvWidth = -1
|
||||
If IsMissing(pvHeight) Then pvHeight = -1
|
||||
If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
|
||||
Dim iArg As Integer, iWrong As Integer ' Check arguments values
|
||||
iArg = 0
|
||||
If pvHeight < -1 Then
|
||||
iArg = 4 : iWrong = pvHeight
|
||||
ElseIf pvWidth < -1 Then
|
||||
iArg = 3 : iWrong = pvWidth
|
||||
ElseIf pvTop < -1 Then
|
||||
iArg = 2 : iWrong = pvTop
|
||||
ElseIf pvLeft < -1 Then
|
||||
iArg = 1 : iWrong = pvLeft
|
||||
End If
|
||||
If iArg > 0 Then
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong))
|
||||
Goto Exit_Function
|
||||
End If
|
||||
|
||||
Dim iPosSize As Integer
|
||||
iPosSize = 0
|
||||
If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X
|
||||
If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y
|
||||
If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH
|
||||
If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT
|
||||
If iPosSize > 0 Then UnoDialog.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize)
|
||||
Move = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.Move")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog.Move", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Move
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Utils._SetCalledSub("Dialog.setProperty")
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub("Dialog.setProperty")
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Start() As Boolean
|
||||
' Create dialog
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Dialog.Start")
|
||||
|
||||
Dim oStart As Object
|
||||
Start = False
|
||||
If IsNull(_Dialog) Then Goto Error_Start
|
||||
If Not IsNull(UnoDialog) Then Goto Error_Yet_Started
|
||||
Set oStart = CreateUnoDialog(_Dialog)
|
||||
If IsNull(oStart) Then
|
||||
Goto Error_Start
|
||||
Else
|
||||
Start = True
|
||||
Set UnoDialog = oStart
|
||||
With _A2B_
|
||||
If .hasItem(COLLALLDIALOGS, _Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate
|
||||
.Dialogs.Add(UnoDialog, UCase(_Name))
|
||||
End With
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.Start")
|
||||
Exit Function
|
||||
Error_Start:
|
||||
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_Yet_Started:
|
||||
TraceError(TRACEWARNING, ERRDIALOGSTARTED, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog.Start", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Start
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Terminate() As Boolean
|
||||
' Close dialog
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Dialog.Terminate")
|
||||
|
||||
Terminate = False
|
||||
If IsNull(_Dialog) Then Goto Error_Terminate
|
||||
If IsNull(UnoDialog) Then Goto Error_Not_Started
|
||||
UnoDialog.Dispose()
|
||||
Set UnoDialog = Nothing
|
||||
_A2B_.Dialogs.Remove(_Name)
|
||||
Terminate = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.Terminate")
|
||||
Exit Function
|
||||
Error_Terminate:
|
||||
TraceError(TRACEFATAL, ERRDIALOGUNDEFINED, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_Not_Started:
|
||||
TraceError(TRACEWARNING, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog.Terminate", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Terminate
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _GetListener(ByVal psProperty As String) As String
|
||||
' Return the X...Listener corresponding with the property in argument
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("OnFocusGained"), UCase("OnFocusLost")
|
||||
_GetListener = "XFocusListener"
|
||||
Case UCase("OnKeyPressed"), UCase("OnKeyReleased")
|
||||
_GetListener = "XKeyListener"
|
||||
Case UCase("OnMouseDragged"), UCase("OnMouseMoved")
|
||||
_GetListener = "XMouseMotionListener"
|
||||
Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased")
|
||||
_GetListener = "XMouseListener"
|
||||
End Select
|
||||
|
||||
End Function ' _GetListener V1.7.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
If IsLoaded Then
|
||||
_PropertiesList = Array("Caption", "Height", "IsLoaded", "Name" _
|
||||
, "OnFocusGained", "OnFocusLost", "OnKeyPressed", "OnKeyReleased", "OnMouseDragged" _
|
||||
, "OnMouseEntered", "OnMouseExited", "OnMouseMoved", "OnMousePressed", "OnMouseReleased" _
|
||||
, "ObjectType", "Page", "Visible", "Width" _
|
||||
)
|
||||
Else
|
||||
_PropertiesList = Array("IsLoaded", "Name" _
|
||||
)
|
||||
End If
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Dialog.get" & psProperty)
|
||||
|
||||
Dim oDialogEvents As Object, sEventName As String
|
||||
|
||||
'Execute
|
||||
_PropertyGet = EMPTY
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Name"), UCase("IsLoaded")
|
||||
Case Else
|
||||
If IsNull(UnoDialog) Then Goto Trace_Error_Dialog
|
||||
End Select
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Caption")
|
||||
_PropertyGet = UnoDialog.getTitle()
|
||||
Case UCase("Height")
|
||||
_PropertyGet = UnoDialog.getPosSize().Height
|
||||
Case UCase("IsLoaded")
|
||||
_PropertyGet = _A2B_.hasItem(COLLALLDIALOGS, _Name)
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
|
||||
, UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
|
||||
, UCase("OnMousePressed"), UCase("OnMouseReleased")
|
||||
Set oDialogEvents = unoDialog.Model.getEvents()
|
||||
sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty)
|
||||
If oDialogEvents.hasByName(sEventName) Then
|
||||
_PropertyGet = oDialogEvents.getByName(sEventName).ScriptCode
|
||||
Else
|
||||
_PropertyGet = ""
|
||||
End If
|
||||
Case UCase("Page")
|
||||
_PropertyGet = UnoDialog.Model.Step
|
||||
Case UCase("Visible")
|
||||
_PropertyGet = UnoDialog.IsVisible()
|
||||
Case UCase("Width")
|
||||
_PropertyGet = UnoDialog.getPosSize().Width
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Trace_Error_Dialog:
|
||||
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog._PropertyGet", Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
|
||||
Utils._SetCalledSub("Dialog.set" & psProperty)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
_PropertySet = True
|
||||
|
||||
Dim oDialogEvents As Object, sEventName As String, oEvent As Object, sListener As String, sEvent As String
|
||||
|
||||
'Execute
|
||||
Dim iArgNr As Integer
|
||||
|
||||
If _IsLeft(_A2B_.CalledSub, "Dialog.") Then iArgNr = 1 Else iArgNr = 2
|
||||
If IsNull(UnoDialog) Then Goto Trace_Error_Dialog
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Caption")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
UnoDialog.setTitle(pvValue)
|
||||
Case UCase("Height")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
UnoDialog.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT)
|
||||
Case UCase("OnFocusGained"), UCase("OnFocusLost"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
|
||||
, UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
|
||||
, UCase("OnMousePressed"), UCase("OnMouseReleased")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
If Not Utils._RegisterDialogEventScript(UnoDialog.Model _
|
||||
, psProperty _
|
||||
, _GetListener(psProperty) _
|
||||
, pvValue _
|
||||
) Then GoTo Trace_Error_Dialog
|
||||
Case UCase("Page")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If pvValue < 0 Then Goto Trace_Error_Value
|
||||
UnoDialog.Model.Step = pvValue
|
||||
Case UCase("Visible")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
UnoDialog.setVisible(pvValue)
|
||||
Case UCase("Width")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value
|
||||
UnoDialog.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH)
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Dialog.set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error_Dialog:
|
||||
TraceError(TRACEFATAL, ERRDIALOGNOTSTARTED, Utils._CalledSub(), 0, 1, _Name)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Dialog._PropertySet", Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,493 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Event" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be EVENT
|
||||
Private _EventSource As Object
|
||||
Private _EventType As String
|
||||
Private _EventName As String
|
||||
Private _SubComponentName As String
|
||||
Private _SubComponentType As Long
|
||||
Private _ContextShortcut As String
|
||||
Private _ButtonLeft As Boolean ' com.sun.star.awt.MouseButton.XXX
|
||||
Private _ButtonRight As Boolean
|
||||
Private _ButtonMiddle As Boolean
|
||||
Private _XPos As Variant ' Null or Long
|
||||
Private _YPos As Variant ' Null or Long
|
||||
Private _ClickCount As Long
|
||||
Private _KeyCode As Integer ' com.sun.star.awt.Key.XXX
|
||||
Private _KeyChar As String
|
||||
Private _KeyFunction As Integer ' com.sun.star.awt.KeyFunction.XXX
|
||||
Private _KeyAlt As Boolean
|
||||
Private _KeyCtrl As Boolean
|
||||
Private _KeyShift As Boolean
|
||||
Private _FocusChangeTemporary As Boolean ' False if user action in same window
|
||||
Private _RowChangeAction As Long ' com.sun.star.sdb.RowChangeAction.XXX
|
||||
Private _Recommendation As String ' "IGNORE" or ""
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJEVENT
|
||||
_EventSource = Nothing
|
||||
_EventType = ""
|
||||
_EventName = ""
|
||||
_SubComponentName = ""
|
||||
_SubComponentType = -1
|
||||
_ContextShortcut = ""
|
||||
_ButtonLeft = False ' See com.sun.star.awt.MouseButton.XXX
|
||||
_ButtonRight = False
|
||||
_ButtonMiddle = False
|
||||
_XPos = Null
|
||||
_YPos = Null
|
||||
_ClickCount = 0
|
||||
_KeyCode = 0
|
||||
_KeyChar = ""
|
||||
_KeyFunction = com.sun.star.awt.KeyFunction.DONTKNOW
|
||||
_KeyAlt = False
|
||||
_KeyCtrl = False
|
||||
_KeyShift = False
|
||||
_FocusChangeTemporary = False
|
||||
_RowChangeAction = 0
|
||||
_Recommendation = ""
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ButtonLeft() As Variant
|
||||
ButtonLeft = _PropertyGet("ButtonLeft")
|
||||
End Property ' ButtonLeft (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ButtonMiddle() As Variant
|
||||
ButtonMiddle = _PropertyGet("ButtonMiddle")
|
||||
End Property ' ButtonMiddle (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ButtonRight() As Variant
|
||||
ButtonRight = _PropertyGet("ButtonRight")
|
||||
End Property ' ButtonRight (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ClickCount() As Variant
|
||||
ClickCount = _PropertyGet("ClickCount")
|
||||
End Property ' ClickCount (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ContextShortcut() As Variant
|
||||
ContextShortcut = _PropertyGet("ContextShortcut")
|
||||
End Property ' ContextShortcut (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get EventName() As Variant
|
||||
EventName = _PropertyGet("EventName")
|
||||
End Property ' EventName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get EventSource() As Variant
|
||||
EventSource = _PropertyGet("EventSource")
|
||||
End Property ' EventSource (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get EventType() As Variant
|
||||
EventType = _PropertyGet("EventType")
|
||||
End Property ' EventType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get FocusChangeTemporary() As Variant
|
||||
FocusChangeTemporary = _PropertyGet("FocusChangeTemporary")
|
||||
End Property ' FocusChangeTemporary (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get KeyAlt() As Variant
|
||||
KeyAlt = _PropertyGet("KeyAlt")
|
||||
End Property ' KeyAlt (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get KeyChar() As Variant
|
||||
KeyChar = _PropertyGet("KeyChar")
|
||||
End Property ' KeyChar (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get KeyCode() As Variant
|
||||
KeyCode = _PropertyGet("KeyCode")
|
||||
End Property ' KeyCode (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get KeyCtrl() As Variant
|
||||
KeyCtrl = _PropertyGet("KeyCtrl")
|
||||
End Property ' KeyCtrl (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get KeyFunction() As Variant
|
||||
KeyFunction = _PropertyGet("KeyFunction")
|
||||
End Property ' KeyFunction (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get KeyShift() As Variant
|
||||
KeyShift = _PropertyGet("KeyShift")
|
||||
End Property ' KeyShift (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Recommendation() As Variant
|
||||
Recommendation = _PropertyGet("Recommendation")
|
||||
End Property ' Recommendation (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get RowChangeAction() As Variant
|
||||
RowChangeAction = _PropertyGet("RowChangeAction")
|
||||
End Property ' RowChangeAction (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Source() As Variant
|
||||
' Return the object having fired the event: Form, Control or SubForm
|
||||
' Else return the root Database object
|
||||
Source = _PropertyGet("Source")
|
||||
End Function ' Source (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get SubComponentName() As String
|
||||
SubComponentName = _PropertyGet("SubComponentName")
|
||||
End Property ' SubComponentName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get SubComponentType() As Long
|
||||
SubComponentType = _PropertyGet("SubComponentType")
|
||||
End Property ' SubComponentType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get XPos() As Variant
|
||||
XPos = _PropertyGet("XPos")
|
||||
End Property ' XPos (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get YPos() As Variant
|
||||
YPos = _PropertyGet("YPos")
|
||||
End Property ' YPos (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("Form.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("Form.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub _Initialize(poEvent As Object)
|
||||
|
||||
Dim oObject As Object, i As Integer
|
||||
Dim sShortcut As String, sAddShortcut As String, sArray() As String
|
||||
Dim sImplementation As String, oSelection As Object
|
||||
Dim iCurrentDoc As Integer, oDoc As Object
|
||||
Dim vPersistent As Variant
|
||||
Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm"
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Set oObject = poEvent.Source
|
||||
_EventSource = oObject
|
||||
sArray = Split(Utils._getUNOTypeName(poEvent), ".")
|
||||
_EventType = UCase(sArray(UBound(sArray)))
|
||||
If Utils._hasUNOProperty(poEvent, "EventName") Then _EventName = poEvent.EventName
|
||||
|
||||
Select Case _EventType
|
||||
Case "DOCUMENTEVENT"
|
||||
'SubComponent processing
|
||||
Select Case UCase(_EventName)
|
||||
Case UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened")
|
||||
Set oSelection = poEvent.ViewController.getSelection()(0)
|
||||
_SubComponentName = oSelection.Name
|
||||
With com.sun.star.sdb.application.DatabaseObject
|
||||
Select Case oSelection.Type
|
||||
Case .TABLE : _SubComponentType = acTable
|
||||
Case .QUERY : _SubComponentType = acQuery
|
||||
Case .FORM : _SubComponentType = acForm
|
||||
Case .REPORT : _SubComponentType = acReport
|
||||
Case Else
|
||||
End Select
|
||||
End With
|
||||
Case Else
|
||||
End Select
|
||||
Case "EVENTOBJECT"
|
||||
Case "ACTIONEVENT"
|
||||
Case "FOCUSEVENT"
|
||||
_FocusChangeTemporary = poEvent.Temporary
|
||||
Case "ITEMEVENT"
|
||||
Case "INPUTEVENT", "KEYEVENT"
|
||||
_KeyCode = poEvent.KeyCode
|
||||
_KeyChar = poEvent.KeyChar
|
||||
_KeyFunction = poEvent.KeyFunc
|
||||
_KeyAlt = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD2)
|
||||
_KeyCtrl = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD1)
|
||||
_KeyShift = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.SHIFT)
|
||||
Case "MOUSEEVENT"
|
||||
_ButtonLeft = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.LEFT)
|
||||
_ButtonRight = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.RIGHT)
|
||||
_ButtonMiddle = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.MIDDLE)
|
||||
_XPos = poEvent.X
|
||||
_YPos = poEvent.Y
|
||||
_ClickCount = poEvent.ClickCount
|
||||
Case "ROWCHANGEEVENT"
|
||||
_RowChangeAction = poEvent.Action
|
||||
Case "TEXTEVENT"
|
||||
Case "ADJUSTMENTEVENT", "DOCKINGEVENT", "ENDDOCKINGEVENT", "ENDPOPUPMODEEVENT", "ENHANCEDMOUSEEVENT" _
|
||||
, "MENUEVENT", "PAINTEVENT", "SPINEVENT", "VCLCONTAINEREVENT", "WINDOWEVENT"
|
||||
Goto Exit_Function
|
||||
Case Else
|
||||
Goto Exit_Function
|
||||
End Select
|
||||
|
||||
' Evaluate ContextShortcut
|
||||
sShortcut = ""
|
||||
sImplementation = Utils._ImplementationName(oObject)
|
||||
|
||||
Select Case True
|
||||
Case sImplementation = "stardiv.Toolkit.UnoDialogControl" ' Dialog
|
||||
_ContextShortcut = "Dialogs!" & _EventSource.Model.Name
|
||||
Goto Exit_Function
|
||||
Case Left(sImplementation, 16) = "stardiv.Toolkit." ' Control in Dialog
|
||||
_ContextShortcut = "Dialogs!" & _EventSource.Context.Model.Name _
|
||||
& "!" & _EventSource.Model.Name
|
||||
Goto Exit_Function
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
iCurrentDoc = _A2B_.CurrentDocIndex(, False)
|
||||
If iCurrentDoc < 0 Then Goto Exit_Function
|
||||
Set oDoc = _A2B_.CurrentDocument(iCurrentDoc)
|
||||
|
||||
' To manage 2x triggers of "Before record action" form event
|
||||
If _EventType = "ROWCHANGEEVENT" And sImplementation <> "com.sun.star.comp.forms.ODatabaseForm" Then _Recommendation = "IGNORE"
|
||||
|
||||
Do While sImplementation <> "SwXTextDocument"
|
||||
sAddShortcut = ""
|
||||
Select Case sImplementation
|
||||
Case "com.sun.star.comp.forms.OFormsCollection" ' Do nothing
|
||||
Case Else
|
||||
If Utils._hasUNOProperty(oObject, "Model") Then
|
||||
If oObject.Model.Name <> "MainForm" And oObject.Model.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Model.Name)
|
||||
ElseIf Utils._hasUNOProperty(oObject, "Name") Then
|
||||
If oObject.Name <> "MainForm" And oObject.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Name)
|
||||
End If
|
||||
If sAddShortcut <> "" Then
|
||||
If sImplementation = cstDatabaseForm And oDoc.DbConnect = DBCONNECTBASE Then sAddShortcut = sAddShortcut & ".Form"
|
||||
sShortcut = sAddShortcut & Iif(Len(sShortcut) > 0, "!" & sShortcut, "")
|
||||
End If
|
||||
End Select
|
||||
Select Case True
|
||||
Case Utils._hasUNOProperty(oObject, "Model")
|
||||
Set oObject = oObject.Model.Parent
|
||||
Case Utils._hasUNOProperty(oObject, "Parent")
|
||||
Set oObject = oObject.Parent
|
||||
Case Else
|
||||
Goto Exit_Function
|
||||
End Select
|
||||
sImplementation = Utils._ImplementationName(oObject)
|
||||
Loop
|
||||
' Add Forms! prefix
|
||||
Select Case oDoc.DbConnect
|
||||
Case DBCONNECTBASE
|
||||
vPersistent = Split(oObject.StringValue, "/")
|
||||
sAddShortcut = Utils._Surround(_GetHierarchicalName(vPersistent(UBound(vPersistent) - 1)))
|
||||
sShortcut = "Forms!" & sAddShortcut & "!" & sShortcut
|
||||
Case DBCONNECTFORM
|
||||
sShortcut = "Forms!0!" & sShortcut
|
||||
End Select
|
||||
|
||||
sArray = Split(sShortcut, "!")
|
||||
' If presence of "Forms!myform!myform.Form", eliminate 2nd element
|
||||
' Eliminate anyway blanco subcomponents (e.g. Forms!!myForm)
|
||||
If UBound(sArray) >= 2 Then
|
||||
If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then sArray(1) = ""
|
||||
sArray = Utils._TrimArray(sArray)
|
||||
End If
|
||||
' If first element ends with .Form, remove suffix
|
||||
If UBound(sArray) >= 1 Then
|
||||
If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then sArray(1) = left(sArray(1), Len(sArray(1)) - 5)
|
||||
sShortcut = Join(sArray, "!")
|
||||
End If
|
||||
If Len(sShortcut) >= 2 Then
|
||||
If Right(sShortcut, 1) = "!" Then
|
||||
_ContextShortcut = Left(sShortcut, Len(sShortcut) - 1)
|
||||
Else
|
||||
_ContextShortcut = sShortcut
|
||||
End If
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Sub
|
||||
Error_Function:
|
||||
TraceError(TRACEWARNING, Err, "Event.Initialize", Erl)
|
||||
GoTo Exit_Function
|
||||
End Sub ' _Initialize V0.9.1
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
Dim sSubComponentName As String, sSubComponentType As String
|
||||
sSubComponentName = Iif(_SubComponentType > -1, "SubComponentName", "")
|
||||
sSubComponentType = Iif(_SubComponentType > -1, "SubComponentType", "")
|
||||
Dim sXPos As String, sYPos As String
|
||||
sXPos = Iif(IsNull(_XPos), "", "XPos")
|
||||
sYPos = Iif(IsNull(_YPos), "", "YPos")
|
||||
|
||||
_PropertiesList = Utils._TrimArray(Array( _
|
||||
"ButtonLeft", "ButtonRight", "ButtonMiddle", "ClickCount" _
|
||||
, "ContextShortcut", "EventName", "EventType", "FocusChangeTemporary", _
|
||||
, "KeyAlt", "KeyChar", "KeyCode", "KeyCtrl", "KeyFunction", "KeyShift" _
|
||||
, "ObjectType", "Recommendation", "RowChangeAction", "Source" _
|
||||
, sSubComponentName, sSubComponentType, sXPos, sYPos _
|
||||
))
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Event.get" & psProperty)
|
||||
|
||||
_PropertyGet = EMPTY
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("ButtonLeft")
|
||||
_PropertyGet = _ButtonLeft
|
||||
Case UCase("ButtonMiddle")
|
||||
_PropertyGet = _ButtonMiddle
|
||||
Case UCase("ButtonRight")
|
||||
_PropertyGet = _ButtonRight
|
||||
Case UCase("ClickCount")
|
||||
_PropertyGet = _ClickCount
|
||||
Case UCase("ContextShortcut")
|
||||
_PropertyGet = _ContextShortcut
|
||||
Case UCase("FocusChangeTemporary")
|
||||
_PropertyGet = _FocusChangeTemporary
|
||||
Case UCase("EventName")
|
||||
_PropertyGet = _EventName
|
||||
Case UCase("EventSource")
|
||||
_PropertyGet = _EventSource
|
||||
Case UCase("EventType")
|
||||
_PropertyGet = _EventType
|
||||
Case UCase("KeyAlt")
|
||||
_PropertyGet = _KeyAlt
|
||||
Case UCase("KeyChar")
|
||||
_PropertyGet = _KeyChar
|
||||
Case UCase("KeyCode")
|
||||
_PropertyGet = _KeyCode
|
||||
Case UCase("KeyCtrl")
|
||||
_PropertyGet = _KeyCtrl
|
||||
Case UCase("KeyFunction")
|
||||
_PropertyGet = _KeyFunction
|
||||
Case UCase("KeyShift")
|
||||
_PropertyGet = _KeyShift
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Recommendation")
|
||||
_PropertyGet = _Recommendation
|
||||
Case UCase("RowChangeAction")
|
||||
_PropertyGet = _RowChangeAction
|
||||
Case UCase("Source")
|
||||
If _ContextShortcut = "" Then
|
||||
_PropertyGet = _EventSource
|
||||
Else
|
||||
_PropertyGet = getObject(_ContextShortcut)
|
||||
End If
|
||||
Case UCase("SubComponentName")
|
||||
_PropertyGet = _SubComponentName
|
||||
Case UCase("SubComponentType")
|
||||
_PropertyGet = _SubComponentType
|
||||
Case UCase("XPos")
|
||||
If IsNull(_XPos) Then Goto Trace_Error
|
||||
_PropertyGet = _XPos
|
||||
Case UCase("YPos")
|
||||
If IsNull(_YPos) Then Goto Trace_Error
|
||||
_PropertyGet = _YPos
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Event.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
' Errors are not displayed to avoid display infinite cycling
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, False, psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet V1.1.0
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,923 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Field" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be FIELD
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _Precision As Long
|
||||
Private _ParentName As String
|
||||
Private _ParentType As String
|
||||
Private _ParentDatabase As Object
|
||||
Private _ParentRecordset As Object
|
||||
Private _DefaultValue As String
|
||||
Private _DefaultValueSet As Boolean
|
||||
Private Column As Object ' com.sun.star.sdb.OTableColumnWrapper
|
||||
' or org.openoffice.comp.dbaccess.OQueryColumn
|
||||
' or com.sun.star.sdb.ODataColumn
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJFIELD
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
_ParentName = ""
|
||||
_ParentType = ""
|
||||
_DefaultValue = ""
|
||||
_DefaultValueSet = False
|
||||
Set Column = Nothing
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Property Get DataType() As Long ' AOO/LibO type
|
||||
DataType = _PropertyGet("DataType")
|
||||
End Property ' DataType (get)
|
||||
|
||||
Property Get DataUpdatable() As Boolean
|
||||
DataUpdatable = _PropertyGet("DataUpdatable")
|
||||
End Property ' DataUpdatable (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get DbType() As Long ' MSAccess type
|
||||
DbType = _PropertyGet("DbType")
|
||||
End Property ' DbType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get DefaultValue() As Variant
|
||||
DefaultValue = _PropertyGet("DefaultValue")
|
||||
End Property ' DefaultValue (get)
|
||||
|
||||
Property Let DefaultValue(ByVal pvDefaultValue As Variant)
|
||||
Call _PropertySet("DefaultValue", pvDefaultValue)
|
||||
End Property ' DefaultValue (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Description() As Variant
|
||||
Description = _PropertyGet("Description")
|
||||
End Property ' Description (get)
|
||||
|
||||
Property Let Description(ByVal pvDescription As Variant)
|
||||
Call _PropertySet("Description", pvDescription)
|
||||
End Property ' Description (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get FieldSize() As Long
|
||||
FieldSize = _PropertyGet("FieldSize")
|
||||
End Property ' FieldSize (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Size() As Long
|
||||
Size = _PropertyGet("Size")
|
||||
End Property ' Size (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get SourceField() As String
|
||||
SourceField = _PropertyGet("SourceField")
|
||||
End Property ' SourceField (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get SourceTable() As String
|
||||
SourceTable = _PropertyGet("SourceTable")
|
||||
End Property ' SourceTable (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get TypeName() As String
|
||||
TypeName = _PropertyGet("TypeName")
|
||||
End Property ' TypeName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Value() As Variant
|
||||
Value = _PropertyGet("Value")
|
||||
End Property ' Value (get)
|
||||
|
||||
Property Let Value(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Value", pvValue)
|
||||
End Property ' Value (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function AppendChunk(ByRef Optional pvValue As Variant) As Boolean
|
||||
' Store a chunk of string or binary characters into the current field, presumably a large object (CLOB or BLOB)
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Const cstThisSub = "Field.AppendChunk"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
AppendChunk = False
|
||||
|
||||
If IsMissing(pvValue) Then Call _TraceArguments()
|
||||
|
||||
If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
|
||||
If Not Column.IsWritable Then Goto Trace_Error_Updatable
|
||||
If Column.IsReadOnly Then Goto Trace_Error_Updatable
|
||||
If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
|
||||
|
||||
Dim iChunkType As Integer
|
||||
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES
|
||||
' Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
|
||||
' iChunkType = vbString
|
||||
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB, .CHAR ' .CHAR added for Sqlite3
|
||||
iChunkType = vbByte
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
End With
|
||||
|
||||
AppendChunk = _ParentRecordset._AppendChunk(_Name, pvValue, iChunkType)
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error_Update:
|
||||
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Updatable:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' AppendChunk V1.5.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function GetChunk(ByVal Optional pvOffset As Variant, ByVal Optional pvBytes As Variant) As Variant
|
||||
' Get a chunk of string or binary characters from the current field, presumably a large object (CLOB or BLOB)
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Const cstThisSub = "Field.GetChunk"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim oValue As Object, bNullable As Boolean, bNull As Boolean, vValue() As Variant
|
||||
Dim lLength As Long, lOffset As Long, lValue As Long
|
||||
|
||||
If IsMissing(pvOffset) Or IsMissing(pvBytes) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvOffset, 1, _AddNumeric()) Then Goto Exit_Function
|
||||
If pvOffset < 0 Then
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvOffset))
|
||||
Goto Exit_Function
|
||||
End If
|
||||
If Not Utils._CheckArgument(pvBytes, 2, _AddNumeric()) Then Goto Exit_Function
|
||||
If pvBytes < 0 Then
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(2, pvBytes))
|
||||
Goto Exit_Function
|
||||
End If
|
||||
|
||||
bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
|
||||
bNull = False
|
||||
GetChunk = Null
|
||||
vValue = Array()
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES
|
||||
' Case .CHAR, .VARCHAR, .LONGVARCHAR
|
||||
' Set oValue = Column.getCharacterStream()
|
||||
' Case .CLOB
|
||||
' Set oValue = Column.getClob.getCharacterStream()
|
||||
Case .BINARY, .VARBINARY, .LONGVARBINARY
|
||||
Set oValue = Column.getBinaryStream()
|
||||
Case .BLOB
|
||||
Set oValue = Column.getBlob.getBinaryStream()
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
If bNullable Then bNull = Column.wasNull()
|
||||
If Not bNull Then
|
||||
lOffset = CLng(pvOffset)
|
||||
If lOffset > 0 Then oValue.skipBytes(lOffset)
|
||||
lValue = oValue.readBytes(vValue, pvBytes)
|
||||
End If
|
||||
oValue.closeInput()
|
||||
End With
|
||||
GetChunk = vValue
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub)
|
||||
Goto Exit_Function
|
||||
Trace_Argument:
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex))
|
||||
Set vForms = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' GetChunk V1.5.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Const cstThisSub = "Field.getProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
Const cstThisSub = "Field.hasProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String, sName As String
|
||||
Const cstThisSub = "Field.Properties"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
sName = _ParentType & "/" & _ParentName & "/" & _Name
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
Set vProperty._ParentDatabase = _ParentDatabase
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function ReadAllBytes(ByVal Optional pvFile As Variant) As Boolean
|
||||
' Read the whole content of a file into Long Binary Field object
|
||||
|
||||
Const cstThisSub = "Field.ReadAllBytes"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
|
||||
ReadAllBytes = _ReadAll(pvFile, "ReadAllBytes")
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' ReadAllBytes
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function ReadAllText(ByVal Optional pvFile As Variant) As Boolean
|
||||
' Read the whole content of a file into a Long Char Field object
|
||||
|
||||
Const cstThisSub = "Field.ReadAllText"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
|
||||
ReadAllText = _ReadAll(pvFile, "ReadAllText")
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' ReadAllText
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Const cstThisSub = "Field.setProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function WriteAllBytes(ByVal Optional pvFile As Variant) As Boolean
|
||||
' Write the whole content of a Long Binary Field object to a file
|
||||
|
||||
Const cstThisSub = "Field.WriteAllBytes"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
|
||||
WriteAllBytes = _WriteAll(pvFile, "WriteAllBytes")
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' WriteAllBytes
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function WriteAllText(ByVal Optional pvFile As Variant) As Boolean
|
||||
' Write the whole content of a Long Char Field object to a file
|
||||
|
||||
Const cstThisSub = "Field.WriteAllText"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
|
||||
WriteAllText = _WriteAll(pvFile, "WriteAllText")
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' WriteAllText
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
Select Case _ParentType
|
||||
Case OBJTABLEDEF
|
||||
_PropertiesList =Array("DataType", "dbType", "DefaultValue" _
|
||||
, "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _
|
||||
, "TypeName" _
|
||||
)
|
||||
Case OBJQUERYDEF
|
||||
_PropertiesList = Array("DataType", "dbType", "DefaultValue" _
|
||||
, "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _
|
||||
, "TypeName" _
|
||||
)
|
||||
Case OBJRECORDSET
|
||||
_PropertiesList = Array("DataType", "DataUpdatable", "dbType", "DefaultValue" _
|
||||
, "Description" , "FieldSize", "Name", "ObjectType" _
|
||||
, "Size", "SourceTable", "TypeName", "Value" _
|
||||
)
|
||||
End Select
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = "Field.get" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
Dim bCond1 As Boolean, bCond2 As Boolean, vValue As Variant, oValue As Object, sValue As String
|
||||
Dim oSize As Object, lSize As Long, bNullable As Boolean, bNull As Boolean
|
||||
Const cstMaxBinlength = 2 * 65535
|
||||
|
||||
_PropertyGet = EMPTY
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("DataType")
|
||||
_PropertyGet = Column.Type
|
||||
Case UCase("DbType")
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type
|
||||
Case .BIT : _PropertyGet = dbBoolean
|
||||
Case .TINYINT : _PropertyGet = dbInteger
|
||||
Case .SMALLINT : _PropertyGet = dbLong
|
||||
Case .INTEGER : _PropertyGet = dbLong
|
||||
Case .BIGINT : _PropertyGet = dbBigInt
|
||||
Case .FLOAT : _PropertyGet = dbFloat
|
||||
Case .REAL : _PropertyGet = dbSingle
|
||||
Case .DOUBLE : _PropertyGet = dbDouble
|
||||
Case .NUMERIC : _PropertyGet = dbNumeric
|
||||
Case .DECIMAL : _PropertyGet = dbDecimal
|
||||
Case .CHAR : _PropertyGet = dbChar
|
||||
Case .VARCHAR : _PropertyGet = dbText
|
||||
Case .LONGVARCHAR : _PropertyGet = dbMemo
|
||||
Case .CLOB : _PropertyGet = dbMemo
|
||||
Case .DATE : _PropertyGet = dbDate
|
||||
Case .TIME : _PropertyGet = dbTime
|
||||
Case .TIMESTAMP : _PropertyGet = dbTimeStamp
|
||||
Case .BINARY : _PropertyGet = dbBinary
|
||||
Case .VARBINARY : _PropertyGet = dbVarBinary
|
||||
Case .LONGVARBINARY : _PropertyGet = dbLongBinary
|
||||
Case .BLOB : _PropertyGet = dbLongBinary
|
||||
Case .BOOLEAN : _PropertyGet = dbBoolean
|
||||
Case Else : _PropertyGet = dbUndefined
|
||||
End Select
|
||||
End With
|
||||
Case UCase("DataUpdatable")
|
||||
If Utils._hasUNOProperty(Column, "IsWritable") Then
|
||||
_PropertyGet = Column.IsWritable
|
||||
ElseIf Utils._hasUNOProperty(Column, "IsReadOnly") Then
|
||||
_PropertyGet = Not Column.IsReadOnly
|
||||
ElseIf Utils._hasUNOProperty(Column, "IsDefinitelyWritable") Then
|
||||
_PropertyGet = Column.IsDefinitelyWritable
|
||||
Else
|
||||
_PropertyGet = False
|
||||
End If
|
||||
If Utils._hasUNOProperty(Column, "IsAutoIncrement") Then
|
||||
If Column.IsAutoIncrement Then _PropertyGet = False ' Forces False if auto-increment (MSAccess)
|
||||
End If
|
||||
Case UCase("DefaultValue")
|
||||
' default value buffered to avoid multiple calls
|
||||
If Not _DefaultValueSet Then
|
||||
If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement
|
||||
_DefaultValue = Column.DefaultValue
|
||||
ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition
|
||||
If IsEmpty(Column.ControlDefault) Then _DefaultValue = "" Else _DefaultValue = Column.ControlDefault
|
||||
Else
|
||||
_DefaultValue = ""
|
||||
End If
|
||||
_DefaultValueSet = True
|
||||
End If
|
||||
_PropertyGet = _DefaultValue
|
||||
Case UCase("Description")
|
||||
bCond1 = Utils._hasUNOProperty(Column, "Description")
|
||||
bCond2 = Utils._hasUNOProperty(Column, "HelpText")
|
||||
Select Case True
|
||||
Case ( bCond1 And bCond2 )
|
||||
If IsEmpty(Column.HelpText) Then _PropertyGet = Column.Description Else _PropertyGet = Column.HelpText
|
||||
Case ( bCond1 And ( Not bCond2 ) )
|
||||
_PropertyGet = Column.Description
|
||||
Case ( ( Not bCond1 ) And bCond2 )
|
||||
_PropertyGet = Column.HelpText
|
||||
Case Else
|
||||
_PropertyGet = ""
|
||||
End Select
|
||||
Case UCase("FieldSize")
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type
|
||||
Case .VARCHAR, .LONGVARCHAR, .CLOB
|
||||
Set oSize = Column.getCharacterStream
|
||||
Case .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB
|
||||
Set oSize = Column.getBinaryStream
|
||||
Case Else
|
||||
Set oSize = Nothing
|
||||
End Select
|
||||
End With
|
||||
If Not IsNull(oSize) Then
|
||||
bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
|
||||
If bNullable Then
|
||||
If Column.wasNull() Then _PropertyGet = 0 Else _PropertyGet = CLng(oSize.getLength())
|
||||
Else
|
||||
_PropertyGet = CLng(oSize.getLength())
|
||||
End If
|
||||
oSize.closeInput()
|
||||
Else
|
||||
_PropertyGet = EMPTY
|
||||
End If
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Size")
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type
|
||||
Case .LONGVARCHAR, .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB, .CLOB
|
||||
_PropertyGet = 0 ' Always 0 (MSAccess)
|
||||
Case Else
|
||||
If Utils._hasUNOProperty(Column, "Precision") Then _PropertyGet = Column.Precision Else _PropertyGet = 0
|
||||
End Select
|
||||
End With
|
||||
Case UCase("SourceField")
|
||||
Select Case _ParentType
|
||||
Case OBJTABLEDEF
|
||||
_PropertyGet = _Name
|
||||
Case OBJQUERYDEF ' RealName = not documented ?!?
|
||||
If Utils._hasUNOProperty(Column, "RealName") Then _PropertyGet = Column.RealName Else _PropertyGet = _Name
|
||||
End Select
|
||||
Case UCase("SourceTable")
|
||||
Select Case _ParentType
|
||||
Case OBJTABLEDEF
|
||||
_PropertyGet = _ParentName
|
||||
Case OBJQUERYDEF, OBJRECORDSET
|
||||
_PropertyGet = Column.TableName
|
||||
End Select
|
||||
Case UCase("TypeName")
|
||||
_PropertyGet = Column.TypeName
|
||||
Case UCase("Value")
|
||||
bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
|
||||
bNull = False
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type
|
||||
Case .BIT, .BOOLEAN : vValue = Column.getBoolean() ' vbBoolean
|
||||
Case .TINYINT : vValue = Column.getShort() ' vbInteger
|
||||
Case .SMALLINT, .INTEGER: vValue = Column.getInt() ' vbLong
|
||||
Case .BIGINT : vValue = Column.getLong() ' vbBigint
|
||||
Case .FLOAT : vValue = Column.getFloat() ' vbSingle
|
||||
Case .REAL, .DOUBLE : vValue = Column.getDouble() ' vbDouble
|
||||
Case .NUMERIC, .DECIMAL
|
||||
If Utils._hasUNOProperty(Column, "Scale") Then
|
||||
If Column.Scale > 0 Then
|
||||
vValue = Column.getDouble()
|
||||
Else ' Try Long otherwise Double (CDec not implemented anymore in LO ?!?)
|
||||
On Local Error Resume Next ' Avoid overflow error
|
||||
' CLng checks local decimal point, getString does not !
|
||||
sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint())
|
||||
vValue = CLng(sValue)
|
||||
If Err <> 0 Then
|
||||
vValue = CDbl(sValue)
|
||||
Err.Clear
|
||||
On Local Error Goto Error_Function
|
||||
End If
|
||||
End If
|
||||
Else
|
||||
vValue = CDbl(Column.getString())
|
||||
End If
|
||||
Case .CHAR : vValue = Column.getString()
|
||||
Case .VARCHAR : vValue = Column.getString() ' vbString
|
||||
Case .LONGVARCHAR, .CLOB
|
||||
Set oValue = Column.getCharacterStream()
|
||||
If bNullable Then bNull = Column.wasNull()
|
||||
If Not bNull Then
|
||||
lSize = CLng(oValue.getLength())
|
||||
oValue.closeInput()
|
||||
vValue = Column.getString() ' vbString
|
||||
Else
|
||||
oValue.closeInput()
|
||||
End If
|
||||
Case .DATE : Set oValue = Column.getDate() ' vbObject with members VarType Unsigned Short = 18
|
||||
If bNullable Then bNull = Column.wasNull()
|
||||
If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day))
|
||||
Case .TIME : Set oValue = Column.getTime() ' vbObject with members VarType Unsigned Short = 18
|
||||
If bNullable Then bNull = Column.wasNull()
|
||||
If Not bNull Then vValue = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds)
|
||||
Case .TIMESTAMP : Set oValue = Column.getTimeStamp()
|
||||
If bNullable Then bNull = Column.wasNull()
|
||||
If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) _
|
||||
+ TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds)
|
||||
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
||||
Set oValue = Column.getBinaryStream()
|
||||
If bNullable Then bNull = Column.wasNull()
|
||||
If Not bNull Then
|
||||
lSize = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize
|
||||
If lSize > cstMaxBinlength Then Goto Trace_Length
|
||||
vValue = Array()
|
||||
oValue.readBytes(vValue, lSize)
|
||||
End If
|
||||
oValue.closeInput()
|
||||
Case Else
|
||||
vValue = Column.getString() 'GIVE STRING A TRY
|
||||
If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
|
||||
End Select
|
||||
If bNullable Then
|
||||
If Column.wasNull() Then vValue = Null 'getXXX must precede wasNull()
|
||||
End If
|
||||
End With
|
||||
_PropertyGet = vValue
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Trace_Length:
|
||||
TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk"))
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = "Field.set" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
_PropertySet = True
|
||||
Dim iArgNr As Integer, vTemp As Variant
|
||||
Dim oParent As Object
|
||||
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("setProperty") : iArgNr = 3
|
||||
Case UCase("Field.setProperty") : iArgNr = 2
|
||||
Case UCase(cstThisSub) : iArgNr = 1
|
||||
End Select
|
||||
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("DefaultValue")
|
||||
If _ParentType <> OBJTABLEDEF Then Goto Trace_Error
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
If Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition
|
||||
Column.ControlDefault = pvValue
|
||||
_DefaultValue = pvValue
|
||||
_DefaultValueSet = True
|
||||
End If
|
||||
Case UCase("Description")
|
||||
If _ParentType <> OBJTABLEDEF Then Goto Trace_Error
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
Column.HelpText = pvValue
|
||||
Case UCase("Value")
|
||||
If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
|
||||
If Not Column.IsWritable Then Goto Trace_Error_Updatable
|
||||
If Column.IsReadOnly Then Goto Trace_Error_Updatable
|
||||
If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
|
||||
With com.sun.star.sdbc.DataType
|
||||
If IsNull(pvValue) Then
|
||||
If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then Column.updateNull() Else Goto Trace_Null
|
||||
Else
|
||||
Select Case Column.Type
|
||||
Case .BIT, .BOOLEAN
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
Column.updateBoolean(pvValue)
|
||||
Case .TINYINT
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If pvValue < -128 Or pvValue > +127 Then Goto Trace_Error_Value
|
||||
Column.updateShort(CInt(pvValue))
|
||||
Case .SMALLINT
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If pvValue < -32768 Or pvValue > 32767 Then Goto trace_Error_Value
|
||||
Column.updateInt(CLng(pvValue))
|
||||
Case .INTEGER
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto trace_Error_Value
|
||||
Column.updateInt(CLng(pvValue))
|
||||
Case .BIGINT
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
Column.updateLong(pvValue) ' No proper type conversion for HYPER data type
|
||||
Case .FLOAT
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then Column.updateFloat(CSng(pvValue)) Else Goto trace_Error_Value
|
||||
Case .REAL, .DOUBLE
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value
|
||||
Column.updateDouble(CDbl(pvValue))
|
||||
Case .NUMERIC, .DECIMAL
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If Utils._hasUNOProperty(Column, "Scale") Then
|
||||
If Column.Scale > 0 Then
|
||||
'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value
|
||||
Column.updateDouble(CDbl(pvValue))
|
||||
Else
|
||||
Column.updateString(CStr(pvValue))
|
||||
End If
|
||||
Else
|
||||
Column.updateString(CStr(pvValue))
|
||||
End If
|
||||
Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
If _Precision > 0 And Len(pvValue) > _Precision Then Goto Trace_Error_Length
|
||||
Column.updateString(pvValue) ' vbString
|
||||
Case .DATE
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
|
||||
vTemp = New com.sun.star.util.Date
|
||||
With vTemp
|
||||
.Day = Day(pvValue)
|
||||
.Month = Month(pvValue)
|
||||
.Year = Year(pvValue)
|
||||
End With
|
||||
Column.updateDate(vTemp)
|
||||
Case .TIME
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
|
||||
vTemp = New com.sun.star.util.Time
|
||||
With vTemp
|
||||
.Hours = Hour(pvValue)
|
||||
.Minutes = Minute(pvValue)
|
||||
.Seconds = Second(pvValue)
|
||||
'.HundredthSeconds = 0 ' replaced with Long nanoSeconds in LO 4.1 ??
|
||||
End With
|
||||
Column.updateTime(vTemp)
|
||||
Case .TIMESTAMP
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
|
||||
vTemp = New com.sun.star.util.DateTime
|
||||
With vTemp
|
||||
.Day = Day(pvValue)
|
||||
.Month = Month(pvValue)
|
||||
.Year = Year(pvValue)
|
||||
.Hours = Hour(pvValue)
|
||||
.Minutes = Minute(pvValue)
|
||||
.Seconds = Second(pvValue)
|
||||
'.HundredthSeconds = 0
|
||||
End With
|
||||
Column.updateTimestamp(vTemp)
|
||||
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
||||
If Not IsArray(pvValue) Then Goto Trace_Error_Value
|
||||
If UBound(pvValue) < LBound(pvValue) Then Goto Trace_Error_Value
|
||||
If Not Utils._CheckArgument(pvValue(LBound(pvValue)), iArgNr, vbInteger, , False) Then Goto Trace_Error_Value
|
||||
Column.updateBytes(pvValue)
|
||||
Case Else
|
||||
Goto trace_Error
|
||||
End Select
|
||||
End If
|
||||
End With
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Null:
|
||||
TraceError(TRACEFATAL, ERRNOTNULLABLE, Utils._CalledSub(), 0, 1, _Name)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Update:
|
||||
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Updatable:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Length:
|
||||
TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(Len(pvValue), "AppendChunk"))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _ReadAll(ByVal psFile As String, ByVal psMethod As String) As Boolean
|
||||
' Write the whole content of a file into a stream object
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
_ReadAll = False
|
||||
|
||||
If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
|
||||
If Not Column.IsWritable Then Goto Trace_Error_Updatable
|
||||
If Column.IsReadOnly Then Goto Trace_Error_Updatable
|
||||
If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
|
||||
|
||||
Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object
|
||||
Dim lFileLength As Long, sBuffer As String, sMemo As String, iFile As Integer
|
||||
Const cstMaxLength = 64000
|
||||
sFile = ConvertToURL(psFile)
|
||||
|
||||
oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
|
||||
If Not oSimpleFileAccess.exists(sFile) Then Goto Trace_File
|
||||
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type
|
||||
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
||||
If psMethod <> "ReadAllBytes" Then Goto Trace_Error
|
||||
Set oStream = oSimpleFileAccess.openFileRead(sFile)
|
||||
lFileLength = oStream.getLength()
|
||||
If lFileLength = 0 Then Goto Trace_File
|
||||
Column.updateBinaryStream(oStream, lFileLength)
|
||||
oStream.closeInput()
|
||||
Case .VARCHAR, .LONGVARCHAR, .CLOB
|
||||
If psMethod <> "ReadAllText" Then Goto Trace_Error
|
||||
sMemo = ""
|
||||
lFileLength = 0
|
||||
iFile = FreeFile()
|
||||
Open sFile For Input Access Read Shared As iFile
|
||||
Do While Not Eof(iFile)
|
||||
Line Input #iFile, sBuffer
|
||||
lFileLength = lFileLength + Len(sBuffer) + 1
|
||||
If lFileLength > cstMaxLength Then Exit Do
|
||||
sMemo = sMemo & sBuffer & vbNewLine
|
||||
Loop
|
||||
If lFileLength = 0 Or lFileLength > cstMaxLength Then
|
||||
Close #iFile
|
||||
Goto Trace_File
|
||||
End If
|
||||
sMemo = Left(sMemo, lFileLength - 1)
|
||||
Column.updateString(sMemo)
|
||||
'Column.updateCharacterStream(oStream, lFileLength) ' DOES NOT WORK ?!?
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
End With
|
||||
|
||||
_ReadAll = True
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod)
|
||||
Goto Exit_Function
|
||||
Trace_File:
|
||||
TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile)
|
||||
If Not IsNull(oStream) Then oStream.closeInput()
|
||||
Goto Exit_Function
|
||||
Trace_Error_Update:
|
||||
TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
|
||||
If Not IsNull(oStream) Then oStream.closeInput()
|
||||
Goto Exit_Function
|
||||
Trace_Error_Updatable:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
|
||||
If Not IsNull(oStream) Then oStream.closeInput()
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, _CalledSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' ReadAll
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _WriteAll(ByVal psFile As String, ByVal psMethod As String) As Boolean
|
||||
' Write the whole content of a stream object to a file
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
_WriteAll = False
|
||||
|
||||
Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object
|
||||
sFile = ConvertToURL(psFile)
|
||||
|
||||
oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
|
||||
With com.sun.star.sdbc.DataType
|
||||
Select Case Column.Type
|
||||
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
|
||||
If psMethod <> "WriteAllBytes" Then Goto Trace_Error
|
||||
Set oStream = Column.getBinaryStream()
|
||||
Case .VARCHAR, .LONGVARCHAR, .CLOB
|
||||
If psMethod <> "WriteAllText" Then Goto Trace_Error
|
||||
Set oStream = Column.getCharacterStream()
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
End With
|
||||
|
||||
If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then
|
||||
If Column.wasNull() Then Goto Trace_Null
|
||||
End If
|
||||
If oStream.getLength() = 0 Then Goto Trace_Null
|
||||
On Local Error Goto Trace_File
|
||||
If oSimpleFileAccess.exists(sFile) Then oSimpleFileAccess.kill(sFile)
|
||||
oSimpleFileAccess.writeFile(sFile, oStream)
|
||||
On Local Error Goto Error_Function
|
||||
oStream.closeInput()
|
||||
|
||||
_WriteAll = True
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod)
|
||||
Goto Exit_Function
|
||||
Trace_File:
|
||||
TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile)
|
||||
If Not IsNull(oStream) Then oStream.closeInput()
|
||||
Goto Exit_Function
|
||||
Trace_Null:
|
||||
TraceError(TRACEFATAL, ERRFIELDNULL, _CalledSub, 0)
|
||||
If Not IsNull(oStream) Then oStream.closeInput()
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, _CalledSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' WriteAll
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,540 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="L10N" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function _GetLabel(ByVal psShortlabel As String, Optional ByVal psLocale As String) As String
|
||||
' Return the localized label corresponding with ShortLabel
|
||||
|
||||
If IsMissing(psLocale) Then psLocale = UCase(Left(_A2B_.Locale, 2)) Else psLocale = UCase(psLocale)
|
||||
On Local Error Goto Error_Function
|
||||
If Not Utils._InList(psLocale, Array( _
|
||||
"EN", "FR", "ES", "DE" _
|
||||
)) Then psLocale = "DEFAULT" ' If list incomplete a recursive call will be provided anyway
|
||||
|
||||
Dim sLocal As String
|
||||
sLocal = psShortLabel
|
||||
Select Case psLocale
|
||||
Case "EN", "DEFAULT"
|
||||
Select Case UCase(psShortlabel)
|
||||
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No active connection to a database found"
|
||||
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Arguments are missing or are not initialized"
|
||||
Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument nr. %0 [Value = '%1'] is invalid"
|
||||
Case "ERR" & ERRMAINFORM : sLocal = "Document '%0' does not contain any form"
|
||||
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Form '%0' not identified in database Forms set"
|
||||
Case "ERR" & ERRFORMNOTFOUND : sLocal = "Form '%0' not found"
|
||||
Case "ERR" & ERRFORMNOTOPEN : sLocal = "Form '%0' is currently not open"
|
||||
Case "ERR" & ERRDFUNCTION : sLocal = "DFunction execution failed, SQL=%0"
|
||||
Case "ERR" & ERROPENFORM : sLocal = "Form '%0' could not be opened"
|
||||
Case "ERR" & ERRPROPERTY : sLocal = "Property '%0' not applicable in this context"
|
||||
Case "ERR" & ERRPROPERTYVALUE : sLocal = "Value '%0' is invalid for property '%1'"
|
||||
Case "ERR" & ERRINDEXVALUE : sLocal = "Out of array range or incorrect array size for property '%0'"
|
||||
Case "ERR" & ERRCOLLECTION : sLocal = "Out of array range"
|
||||
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument nr.%0 should be an array"
|
||||
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Control '%0' not found in parent (form, grid or dialog) '%1'"
|
||||
Case "ERR" & ERRNOACTIVEFORM : sLocal = "No active form or control found"
|
||||
Case "ERR" & ERRDATABASEFORM : sLocal = "Form '%0' has no underlying dataset"
|
||||
Case "ERR" & ERRFOCUSINGRID : sLocal = "Control '%0' not found in gridcontrol '%1'"
|
||||
Case "ERR" & ERRNOGRIDINFORM : sLocal = "No gridcontrol found in form '%0'"
|
||||
Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() must be preceded by a successful FindRecord(...) call"
|
||||
Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'"
|
||||
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' not found"
|
||||
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' could not be opened"
|
||||
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' could not be closed"
|
||||
Case "ERR" & ERRACTION : sLocal = "Action not applicable in this context"
|
||||
Case "ERR" & ERRSENDMAIL : sLocal = "Mail service could not be activated"
|
||||
Case "ERR" & ERRFORMYETOPEN : sLocal = "Form %0 is already open"
|
||||
Case "ERR" & ERRMETHOD : sLocal = "Method '%0' not applicable in this context"
|
||||
Case "ERR" & ERRPROPERTYINIT : sLocal = "Property '%0' applicable but not initialized"
|
||||
Case "ERR" & ERRFILENOTCREATED : sLocal = "File '%0' could not be created"
|
||||
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' not found in the currently loaded libraries"
|
||||
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unknown"
|
||||
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog already started"
|
||||
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' not active"
|
||||
Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset delivered no data. Action on current record rejected"
|
||||
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset has been closed. Recordset action rejected"
|
||||
Case "ERR" & ERRRECORDSETRANGE : sLocal = "Current record out of range"
|
||||
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejected in a forward-only or not bookmarkable recordset"
|
||||
Case "ERR" & ERRFIELDNULL : sLocal = "Field is null or empty. Action rejected"
|
||||
Case "ERR" & ERRFILEACCESS : sLocal = "File access error on file '%0'"
|
||||
Case "ERR" & ERROVERFLOW : sLocal = "Field length (%0) exceeds maximum length. Use the '%1' method instead"
|
||||
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Query '%0' is not an action query"
|
||||
Case "ERR" & ERRNOTUPDATABLE : sLocal = "Database, recordset or field is read only"
|
||||
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Recordset update sequence error"
|
||||
Case "ERR" & ERRNOTNULLABLE : sLocal = "Field '%0' must not contain a NULL value"
|
||||
Case "ERR" & ERRROWDELETED : sLocal = "Current row has been deleted by another process or user"
|
||||
Case "ERR" & ERRRECORDSETCLONE : sLocal = "Cloning a cloned Recordset is forbidden"
|
||||
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Pre-existing query '%0' has been deleted"
|
||||
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Pre-existing table '%0' has been deleted"
|
||||
Case "ERR" & ERRTABLECREATION : sLocal = "Table '%0' could not be created"
|
||||
Case "ERR" & ERRFIELDCREATION : sLocal = "Field '%0' could not be created"
|
||||
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Subform '%0' not found in parent form '%1'"
|
||||
Case "ERR" & ERRWINDOW : sLocal = "Current window is not a document"
|
||||
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Field '%0' could not be converted due to incompatibility of field types between the respective database systems"
|
||||
Case "ERR" & ERRPRECISION : sLocal = "Field '%0' could not be loaded in record #%1 due to capacity shortage"
|
||||
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries"
|
||||
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "OBJECT" : sLocal = "Object"
|
||||
Case "TABLE" : sLocal = "Table"
|
||||
Case "QUERY" : slocal = "Query"
|
||||
Case "FORM" : sLocal = "Form"
|
||||
Case "REPORT" : sLocal = "Report"
|
||||
Case "RECORDSET" : sLocal = "Recordset"
|
||||
Case "FIELD" : sLocal = "Field"
|
||||
Case "TEMPVAR" : sLocal = "Temporary variable"
|
||||
Case "COMMANDBAR" : sLocal = "Command bar"
|
||||
Case "COMMANDBARCONTROL" : sLocal = "Command bar control"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "ERR#" : sLocal = "Error #"
|
||||
Case "ERROCCUR" : sLocal = "occurred"
|
||||
Case "ERRLINE" : sLocal = "at line"
|
||||
Case "ERRIN" : sLocal = "in"
|
||||
Case "CALLTO" : sLocal = "a call to function"
|
||||
Case "SAVECONSOLE" : sLocal = "Save console"
|
||||
Case "SAVECONSOLEENTRIES" : sLocal = "The console entries have been saved successfully."
|
||||
Case "QUITSHORT" : sLocal = "Quit"
|
||||
Case "QUIT" : sLocal = "Do you really want to quit the application ? Changed data will be saved."
|
||||
Case "ENTERING" : sLocal = "Entering"
|
||||
Case "EXITING" : sLocal = "Exiting"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGTRACE_HELP" : sLocal = "Manage the console buffer and its entries"
|
||||
Case "DLGTRACE_TITLE" : sLocal = "Console"
|
||||
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Clear the list and resize the circular buffer"
|
||||
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Set max number of entries"
|
||||
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text can be selected, copied, ..."
|
||||
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log file is empty ---"
|
||||
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog"
|
||||
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancel"
|
||||
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Clear the list"
|
||||
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Clear the list"
|
||||
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Register only logging requests above given level"
|
||||
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Set minimal trace level"
|
||||
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validate"
|
||||
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK"
|
||||
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Choose a file and dump the actual list content in it"
|
||||
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Dump to file"
|
||||
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Actual size of list"
|
||||
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Actual number of entries:"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGFORMAT_HELP" : sLocal = "Export the form"
|
||||
Case "DLGFORMAT_TITLE" : sLocal = "OutputTo"
|
||||
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format in which the form should be exported"
|
||||
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Select the output format"
|
||||
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validate your choice"
|
||||
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK"
|
||||
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancel and close the dialog"
|
||||
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancel"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case Else : sLocal = ""
|
||||
End Select
|
||||
Case "FR"
|
||||
Select Case UCase(psShortlabel)
|
||||
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Pas de connexion active trouvée à une banque de données"
|
||||
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Des arguments sont manquants ou non initialisés"
|
||||
Case "ERR" & ERRWRONGARGUMENT : sLocal = "L'argument n° %0 [Valeur = '%1'] n'est pas valable"
|
||||
Case "ERR" & ERRMAINFORM : sLocal = "Le document '%0' ne contient aucun formulaire"
|
||||
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Le formulaire '%0' n'a pas pu être identifié parmi l'ensemble des formulaires de la Database"
|
||||
Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formulaire '%0' non trouvé"
|
||||
Case "ERR" & ERRFORMNOTOPEN : sLocal = "Le formulaire '%0' n'est actuellement pas ouvert"
|
||||
Case "ERR" & ERRDFUNCTION : sLocal = "L'exécution de la ""fonction database"" a échoué, SQL=%0"
|
||||
Case "ERR" & ERROPENFORM : sLocal = "Le formulaire '%0' n'a pas pu être ouvert"
|
||||
Case "ERR" & ERRPROPERTY : sLocal = "La propriété '%0' n'est pas applicable dans ce contexte"
|
||||
Case "ERR" & ERRPROPERTYVALUE : sLocal = "La valeur '%0' est invalide pour la propriété '%1'"
|
||||
Case "ERR" & ERRINDEXVALUE : sLocal = "Indice invalide ou dimension erronée du tableau pour la propriété '%0'"
|
||||
Case "ERR" & ERRCOLLECTION : sLocal = "Indice de tableau invalide"
|
||||
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "L'argument n°%0 doit être un tableau"
|
||||
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Contrôle '%0' non trouvé dans le parent (formulaire, contrôle de table ou dialogue) '%1'"
|
||||
Case "ERR" & ERRNOACTIVEFORM : sLocal = "Pas de formulaire ou de contrôle actif"
|
||||
Case "ERR" & ERRDATABASEFORM : sLocal = "Le formulaire '%0' n'a pas de données sous-jacentes"
|
||||
Case "ERR" & ERRFOCUSINGRID : sLocal = "Contrôle '%0' non trouvé dans le contrôle de table '%1'"
|
||||
Case "ERR" & ERRNOGRIDINFORM : sLocal = "Aucun contrôle de table trouvé dans le formulaire '%0'"
|
||||
Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() doit être précédé par un appel réussi à FindRecord(...)"
|
||||
Case "ERR" & ERRSQLSTATEMENT : sLocal = "Erreur SQL, instruction SQL = '%0'"
|
||||
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' non trouvé(e)"
|
||||
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1': ouverture en échec"
|
||||
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1': fermeture en échec"
|
||||
Case "ERR" & ERRACTION : sLocal = "Action non applicable dans ce contexte"
|
||||
Case "ERR" & ERRSENDMAIL : sLocal = "Le service de messagerie n'a pas pu être activé"
|
||||
Case "ERR" & ERRFORMYETOPEN : sLocal = "Le formulaire %0 est déjà ouvert"
|
||||
Case "ERR" & ERRMETHOD : sLocal = "La méthode '%0' n'est pas applicable dans ce contexte"
|
||||
Case "ERR" & ERRPROPERTYINIT : sLocal = "Propriété '%0' applicable mais non initialisée"
|
||||
Case "ERR" & ERRFILENOTCREATED : sLocal = "Erreur de création du fichier '%0'"
|
||||
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialogue '%0' introuvable dans les librairies chargées actuellement"
|
||||
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Boîte de dialogue inconnue"
|
||||
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialogue déjà initialisé précédemment"
|
||||
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialogue '%0' non initialisé"
|
||||
Case "ERR" & ERRRECORDSETNODATA : sLocal = "Recordset n'a pas fourni de données. Toute action sur les enregistrements est rejetée"
|
||||
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Recordset a été clôturé. Action sur l'enregistrement courant est rejetée"
|
||||
Case "ERR" & ERRRECORDSETRANGE : sLocal = "L'enregistrement courant est hors cadre"
|
||||
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejetée car recordset lisible seulement vers l'avant ou n'acceptant pas de signets"
|
||||
Case "ERR" & ERRFIELDNULL : sLocal = "Champ nul ou vide. Action rejetée"
|
||||
Case "ERR" & ERRFILEACCESS : sLocal = "Erreur d'accès au fichier '%0'"
|
||||
Case "ERR" & ERROVERFLOW : sLocal = "La longueur du champ (%0) dépasse la taille maximale autorisée. Utiliser de préférence la méthode '%1'"
|
||||
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La requête '%0' n'est pas une requête d'action"
|
||||
Case "ERR" & ERRNOTUPDATABLE : sLocal = "La banque de données, le recordset ou le champ sont en lecture seulement"
|
||||
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Erreur de séquence lors de la mise à jour d'un Recordset"
|
||||
Case "ERR" & ERRNOTNULLABLE : sLocal = "Le champ '%0' ne peut pas recevoir une valeur NULLe"
|
||||
Case "ERR" & ERRROWDELETED : sLocal = "L'enregistrement courant a été effacé par un autre processus ou un autre utilisateur"
|
||||
Case "ERR" & ERRRECORDSETCLONE : sLocal = "Le clonage d'un Recordset cloné est interdit"
|
||||
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "La requête existante '%0' a été supprimée"
|
||||
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "La table existante '%0' a été supprimée"
|
||||
Case "ERR" & ERRTABLECREATION : sLocal = "La table '%0' n'a pas pu être créée"
|
||||
Case "ERR" & ERRFIELDCREATION : sLocal = "Le champ '%0' n'a pas pu être créé"
|
||||
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Sous-formulaire '%0' non trouvé dans le formulaire parent '%1'"
|
||||
Case "ERR" & ERRWINDOW : sLocal = "La fenêtre courante n'est pas un document"
|
||||
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Le champ '%0' n'a pas pu être converti à cause d'une incompatibilité entre les types de champs supportés par les systèmes de bases de données respectifs"
|
||||
Case "ERR" & ERRPRECISION : sLocal = "Le champ '%0' n'a pas pu être chargé dans l'enregistrement #%1 par manque de capacité"
|
||||
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Le module '%0' est introuvable dans les librairies chargées actuellement"
|
||||
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "La procédure '%0' est introuvable dans le module '%1'"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "OBJECT" : sLocal = "Objet"
|
||||
Case "TABLE" : sLocal = "Table"
|
||||
Case "QUERY" : slocal = "Requête"
|
||||
Case "FORM" : sLocal = "Formulaire"
|
||||
Case "REPORT" : sLocal = "Rapport"
|
||||
Case "RECORDSET" : sLocal = "Recordset"
|
||||
Case "FIELD" : sLocal = "Champ"
|
||||
Case "TEMPVAR" : sLocal = "Variable temporaire"
|
||||
Case "COMMANDBAR" : sLocal = "Barre de commande"
|
||||
Case "COMMANDBARCONTROL" : sLocal = "Elément de barre de commande"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "ERR#" : sLocal = "L'erreur #"
|
||||
Case "ERROCCUR" : sLocal = "s'est produite"
|
||||
Case "ERRLINE" : sLocal = "à la ligne"
|
||||
Case "ERRIN" : sLocal = "dans"
|
||||
Case "CALLTO" : sLocal = "un appel à la fonction"
|
||||
Case "SAVECONSOLE" : sLocal = "Sauver console"
|
||||
Case "SAVECONSOLEENTRIES" : sLocal = "Les entrées de la console ont été sauvées avec succès."
|
||||
Case "QUITSHORT" : sLocal = "Quitter"
|
||||
Case "QUIT" : sLocal = "Voulez-vous réellement quitter l'application ? Les données modifiées seront sauvées."
|
||||
Case "ENTERING" : sLocal = "Entrée dans"
|
||||
Case "EXITING" : sLocal = "Sortie de"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGTRACE_HELP" : sLocal = "Gestion du tampon de la console et toutes ses entrées"
|
||||
Case "DLGTRACE_TITLE" : sLocal = "Console"
|
||||
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Effacer la liste et redimensionner le tampon circulaire"
|
||||
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Définir le nombre maximum d'entrées"
|
||||
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Le texte peut être sélectionné, copié, ..."
|
||||
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Le fichier journal est vide ---"
|
||||
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue"
|
||||
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Annuler"
|
||||
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Effacer la liste"
|
||||
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Effacer la liste"
|
||||
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "N'enregistrer que les demandes de journalisation à partir du niveau indiqué"
|
||||
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Définir le niveau minimal d'enregistrement"
|
||||
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Valider"
|
||||
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK"
|
||||
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Sélectionner un fichier et y vider le contenu actuel des traces enregistrées"
|
||||
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Vider dans fichier"
|
||||
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Taille actuelle de la liste"
|
||||
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Nombre actuel d'entrées:"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGFORMAT_HELP" : sLocal = "Exporter le formulaire"
|
||||
Case "DLGFORMAT_TITLE" : sLocal = "OutputTo"
|
||||
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format dans lequel le formulaire sera exporté"
|
||||
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Selectionner le format de sortie"
|
||||
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Valider votre choix"
|
||||
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK"
|
||||
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Annuler et fermer la boîte de dialogue"
|
||||
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Annuler"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT")
|
||||
End Select
|
||||
'********************************************************
|
||||
'Translated by Iñigo Zuluaga
|
||||
'********************************************************
|
||||
Case "ES" '(España)
|
||||
Select Case UCase(psShortlabel)
|
||||
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "No se ha encontrado una conexión activa a una base de datos"
|
||||
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Faltan argumentos o no están inicializados"
|
||||
Case "ERR" & ERRWRONGARGUMENT : sLocal = "El argumento nr. %0 [Value = '%1'] no es válido"
|
||||
Case "ERR" & ERRMAINFORM : sLocal = "El documento '%0' no contiene ningún formulario"
|
||||
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "No se ha identificado el formulario '%0' en el conjunto de formularios de la base de datos"
|
||||
Case "ERR" & ERRFORMNOTFOUND : sLocal = "No se ha encontrado el formulario '%0'"
|
||||
Case "ERR" & ERRFORMNOTOPEN : sLocal = "El formulario '%0' no está abierto"
|
||||
Case "ERR" & ERRDFUNCTION : sLocal = "La ejecución de DFunction falló, SQL=%0"
|
||||
Case "ERR" & ERROPENFORM : sLocal = "El formulario '%0' no se puede abrir"
|
||||
Case "ERR" & ERRPROPERTY : sLocal = "La propiedad '%0' no es aplicable en este contexto"
|
||||
Case "ERR" & ERRPROPERTYVALUE : sLocal = "El valor '%0' es inválido para la propiedad '%1'"
|
||||
Case "ERR" & ERRINDEXVALUE : sLocal = "Fuera del rango de la matriz o tamaño incorrecto de la matriz para la propiedad '%0'"
|
||||
Case "ERR" & ERRCOLLECTION : sLocal = "Fuera del rango de la matriz"
|
||||
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "El argumento nr.%0 debería ser una matriz"
|
||||
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "El control '%0' not found in parent (formulario, control de tabla or diálogo) '%1'"
|
||||
Case "ERR" & ERRNOACTIVEFORM : sLocal = "No se ha encontrado un formulario o control activo"
|
||||
Case "ERR" & ERRDATABASEFORM : sLocal = "El formulario '%0' no tiene datos subyacentes"
|
||||
Case "ERR" & ERRFOCUSINGRID : sLocal = "No se ha encontrado el control '%0' en el control de tabla '%1'"
|
||||
Case "ERR" & ERRNOGRIDINFORM : sLocal = "No se ha encontrado un control de tabla en el formulario '%0'"
|
||||
Case "ERR" & ERRFINDRECORD : sLocal = "FindNext() tiene que ser precedido por una llamada exitosa de FindRecord(...)"
|
||||
Case "ERR" & ERRSQLSTATEMENT : sLocal = "Error SQL, instrución SQL = '%0'"
|
||||
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' no encontrado"
|
||||
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' no se puede abrir"
|
||||
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' no se puede abrir"
|
||||
Case "ERR" & ERRACTION : sLocal = "Acción no aplicable en este contexto"
|
||||
Case "ERR" & ERRSENDMAIL : sLocal = "No se puede activar el servicio de correo"
|
||||
Case "ERR" & ERRFORMYETOPEN : sLocal = "El formulario %0 ya está abierto"
|
||||
Case "ERR" & ERRMETHOD : sLocal = "El método '%0' no es aplicable en este contexto"
|
||||
Case "ERR" & ERRPROPERTYINIT : sLocal = "Propiedad '%0' aplicable pero no inicializada"
|
||||
Case "ERR" & ERRFILENOTCREATED : sLocal = "No se ha podido crear el archivo '%0'"
|
||||
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "No se ha encontrado el diálogo '%0' en las bibliotecas cargadas actualmente"
|
||||
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Diálogo desconocido"
|
||||
Case "ERR" & ERRDIALOGSTARTED : sLocal = "El diálogo ya está iniciado"
|
||||
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "El diálogo '%0' no está activo"
|
||||
Case "ERR" & ERRRECORDSETNODATA : sLocal = "El Recordset no suministra datos. La acción en el registro actual rechazada"
|
||||
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "El recorset se ha cerrado. Acción con el Recordset rechazada"
|
||||
Case "ERR" & ERRRECORDSETRANGE : sLocal = "Registro actual fuera de rango"
|
||||
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Acción rechazada en un recorset legible sólo hacia adelante o que no admita marcadores"
|
||||
Case "ERR" & ERRFIELDNULL : sLocal = "El campo es nulo o vacío. Acción rechazada"
|
||||
Case "ERR" & ERRFILEACCESS : sLocal = "Error durante el acceso al archivo '%0'"
|
||||
Case "ERR" & ERROVERFLOW : sLocal = "La longitud del campo (%0) excede la longitud máxima. Reemplazar por el método '%1'"
|
||||
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La consulta '%0' no es una consulta de acción"
|
||||
Case "ERR" & ERRNOTUPDATABLE : sLocal = "La base de datos, el Recordset o el Campo es de sólo lectura"
|
||||
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Error durante la secuencia de actualización del Recordset"
|
||||
Case "ERR" & ERRNOTNULLABLE : sLocal = "El campo '%0' no puede contener un valor NULL"
|
||||
Case "ERR" & ERRROWDELETED : sLocal = "La fila actual ha sido borrada por otro proceso o usuario"
|
||||
Case "ERR" & ERRRECORDSETCLONE : sLocal = "No se puede clonar un Recordset clonado"
|
||||
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Se ha borrado la consulta pre-existente '%0'"
|
||||
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Se ha borrado la tabla pre-existente '%0'"
|
||||
Case "ERR" & ERRTABLECREATION : sLocal = "No se ha podido crear la Tabla '%0'"
|
||||
Case "ERR" & ERRFIELDCREATION : sLocal = "No se ha podido crear el campo '%0'"
|
||||
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "No se ha encontrado el Subformulario '%0' en el subformulario padre '%1'"
|
||||
Case "ERR" & ERRWINDOW : sLocal = "La ventana actual no es un documento"
|
||||
Case "ERR" & ERRCOMPATIBILITY : sLocal = "El campo '%0' no se ha convertido debido a una incompatibilidad de los tipos de campo soportados entre las dos bases de datos"
|
||||
Case "ERR" & ERRPRECISION : sLocal = "El campo '%0' no se ha cargado en el registro #%1 por falta de capacidad"
|
||||
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Module '%0' not found in the currently loaded libraries"
|
||||
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Procedure '%0' not found in module '%1'"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "OBJECT" : sLocal = "Objeto"
|
||||
Case "TABLE" : sLocal = "Tabla"
|
||||
Case "QUERY" : slocal = "Consulta"
|
||||
Case "FORM" : sLocal = "Formulario"
|
||||
Case "REPORT" : sLocal = "Informe"
|
||||
Case "RECORDSET" : sLocal = "Recordset"
|
||||
Case "FIELD" : sLocal = "Campo"
|
||||
Case "TEMPVAR" : sLocal = "Variable temporal"
|
||||
Case "COMMANDBAR" : sLocal = "Barra de comandos"
|
||||
Case "COMMANDBARCONTROL" : sLocal = "Control de barra de comandos"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "ERR#" : sLocal = "Error #"
|
||||
Case "ERROCCUR" : sLocal = "ocurrido"
|
||||
Case "ERRLINE" : sLocal = "en línea"
|
||||
Case "ERRIN" : sLocal = "en"
|
||||
Case "CALLTO" : sLocal = "una llamada a la función"
|
||||
Case "SAVECONSOLE" : sLocal = "Guardar consola"
|
||||
Case "SAVECONSOLEENTRIES" : sLocal = "Las entradas de la consola han sido guardadas correctamente."
|
||||
Case "QUITSHORT" : sLocal = "Cerrar"
|
||||
Case "QUIT" : sLocal = "Quieres realmente cerrar la aplicación? los datos cambiados se guardarán."
|
||||
Case "ENTERING" : sLocal = "Entrando"
|
||||
Case "EXITING" : sLocal = "Saliendo"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGTRACE_HELP" : sLocal = "Gestión del buffer de la consola y sus entradas"
|
||||
Case "DLGTRACE_TITLE" : sLocal = "Consola"
|
||||
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Limpiar la lista y redimensionar el buffer circular"
|
||||
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Definir el número máximo de entradas"
|
||||
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "El texto puede ser seleccionado, copiado, ..."
|
||||
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- El archivo Histórico está vacío ---"
|
||||
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo"
|
||||
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Cancelar"
|
||||
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Limpiar la lista"
|
||||
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Limpiar la lista"
|
||||
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "No registrar más que las peticiones de registro a partir de un nivel indicado"
|
||||
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Definir el nivel mínimo de registro"
|
||||
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Validar"
|
||||
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "Aceptar"
|
||||
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Elegir un archivo y guardar en él el contenido de la lista actual"
|
||||
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Guardar en a archivo"
|
||||
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Tamaño actual de la lista"
|
||||
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Numero actual de entradas:"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGFORMAT_HELP" : sLocal = "Exportar el formulario"
|
||||
Case "DLGFORMAT_TITLE" : sLocal = "Exportar como"
|
||||
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Formato en el que será ser exportado el formulario"
|
||||
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Seleccionar el formato de salida"
|
||||
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Validar su elección"
|
||||
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "Aceptar"
|
||||
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Cancelar y cerrar el diálogo"
|
||||
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Cancelar"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT")
|
||||
End Select
|
||||
'********************************************************
|
||||
'Translated by Gisbert Friege
|
||||
'********************************************************
|
||||
Case "DE"
|
||||
Select Case UCase(psShortlabel)
|
||||
Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Keine aktive Verbindung zu einer Datenbank gefunden"
|
||||
Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Argumente fehlen oder sind nicht initialisiert"
|
||||
Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument Nr. %0 [Wert = '%1'] ist ungültig"
|
||||
Case "ERR" & ERRMAINFORM : sLocal = "Dokument '%0' enthält kein Formular"
|
||||
Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Formular '%0' nicht bei den Datenbank-Formularen erkannt"
|
||||
Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formular '%0' nicht gefunden"
|
||||
Case "ERR" & ERRFORMNOTOPEN : sLocal = "Formular '%0' ist zur Zeit nicht offen"
|
||||
Case "ERR" & ERRDFUNCTION : sLocal = "DFunction Ausführung misslungen, SQL=%0"
|
||||
Case "ERR" & ERROPENFORM : sLocal = "Formular '%0' konnte nicht geöffnet werden"
|
||||
Case "ERR" & ERRPROPERTY : sLocal = "Eigenschaft '%0' in diesem Kontext nicht anwendbar"
|
||||
Case "ERR" & ERRPROPERTYVALUE : sLocal = "Wert '%0' ist ungültig für die Eigenschaft '%1'"
|
||||
Case "ERR" & ERRINDEXVALUE : sLocal = "Außerhalb des Array-Bereichs oder falsche Array-Größe für Eigenschaft '%0'"
|
||||
Case "ERR" & ERRCOLLECTION : sLocal = "Außerhalb des Array-Bereichs"
|
||||
Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "Argument Nr.%0 sollte ein Array sein"
|
||||
Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Steuerelement '%0' nicht gefunden in parent (Formular, Tabelle oder Dialog) '%1'"
|
||||
Case "ERR" & ERRNOACTIVEFORM : sLocal = "Kein aktives Formular oder Steuerelement gefunden"
|
||||
Case "ERR" & ERRDATABASEFORM : sLocal = "Formular '%0' basiert nicht auf einem Datensatz"
|
||||
Case "ERR" & ERRFOCUSINGRID : sLocal = "Steuerelement '%0' im Tabellen-Steuerelement '%1' nicht gefunden"
|
||||
Case "ERR" & ERRNOGRIDINFORM : sLocal = "Kein Tabellen-Steuerelement im Formular '%0' gefunden"
|
||||
Case "ERR" & ERRFINDRECORD : sLocal = "Bei FindNext() muss ein erfolgreicher FindRecord(...)-Aufruf vorhergehen"
|
||||
Case "ERR" & ERRSQLSTATEMENT : sLocal = "SQL Error, SQL statement = '%0'"
|
||||
Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' nicht gefunden"
|
||||
Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' konnte nicht geöffnet werden"
|
||||
Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' konnte nicht geschlossen werden"
|
||||
Case "ERR" & ERRACTION : sLocal = "Aktion in diesem Kontext nicht anwendbar"
|
||||
Case "ERR" & ERRSENDMAIL : sLocal = "Email-Dienst konnte nicht aktiviert werden"
|
||||
Case "ERR" & ERRFORMYETOPEN : sLocal = "Formular %0 ist schon offen"
|
||||
Case "ERR" & ERRMETHOD : sLocal = "Methode '%0' in diesem Kontext nicht anwendbar"
|
||||
Case "ERR" & ERRPROPERTYINIT : sLocal = "Eigenschaft '%0' anwendbar aber nicht initialisiert"
|
||||
Case "ERR" & ERRFILENOTCREATED : sLocal = "Datei '%0' konnte nicht erzeugt werden"
|
||||
Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialog '%0' nicht in den aktuell geladenen Bibliotheken gefunden"
|
||||
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Dialog unbekannt"
|
||||
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialog schon gestartet"
|
||||
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialog '%0' nicht aktiv"
|
||||
Case "ERR" & ERRRECORDSETNODATA : sLocal = "Datensatz ergab keine Daten. Aktion auf aktuellem Datensatz verweigert"
|
||||
Case "ERR" & ERRRECORDSETCLOSED : sLocal = "Datensatz wurde geschlossen. Datensatz-Aktion verweigert"
|
||||
Case "ERR" & ERRRECORDSETRANGE : sLocal = "Aktueller Datensatz außerhalb des Bereichs"
|
||||
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Aktion verweigert auf einem nur vorwärts lesbaren oder keine Textmarken unterstützenden Datensatz"
|
||||
Case "ERR" & ERRFIELDNULL : sLocal = "Feld ist null oder leer. Aktion verweigert"
|
||||
Case "ERR" & ERRFILEACCESS : sLocal = "Dateizugriffs-Fehler bei Datei '%0'"
|
||||
Case "ERR" & ERROVERFLOW : sLocal = "Feldlänge (%0) überschreitet die maximale Länge. Verwende stattdessen die Methode '%1'"
|
||||
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Abfrage '%0' ist keine Aktionsabfrage"
|
||||
Case "ERR" & ERRNOTUPDATABLE : sLocal = "Datenbank, Datensatz oder Feld kann nur gelesen werden"
|
||||
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Datensatz-Update Folgefehler"
|
||||
Case "ERR" & ERRNOTNULLABLE : sLocal = "Feld '%0' darf keinen NULL-Wert haben"
|
||||
Case "ERR" & ERRROWDELETED : sLocal = "Aktuelle Zeile wurde durch einen anderen Prozess oder Benutzer gelösch"
|
||||
Case "ERR" & ERRRECORDSETCLONE : sLocal = "Ein geklonter Datensatz kann nicht geklont werden"
|
||||
Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Bereits vorhandene Abfrage '%0' wurde gelöscht"
|
||||
Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Bereits vorhandene Tabelle '%0' wurde gelöscht"
|
||||
Case "ERR" & ERRTABLECREATION : sLocal = "Tabelle '%0' konnte nicht erzeugt werden"
|
||||
Case "ERR" & ERRFIELDCREATION : sLocal = "Feld '%0' konnte nicht erzeugt werden"
|
||||
Case "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Unterformular '%0' nicht im Eltern-Formular '%1 gefunden"
|
||||
Case "ERR" & ERRWINDOW : sLocal = "Aktuelles Fenster ist kein Dokument"
|
||||
Case "ERR" & ERRCOMPATIBILITY : sLocal = "Feld '%0' konnte wegen inkompatibler Feldtypen der Datenbanksysteme nicht konvertiert werden"
|
||||
Case "ERR" & ERRPRECISION : sLocal = "Feld '%0' konnte wegen fehlender Speicherkapazität nicht in den Datensatz #%1 geladen werden"
|
||||
Case "ERR" & ERRMODULENOTFOUND : sLocal = "Modul '%0' nicht gefunden in den aktuell geladen Bibliotheken"
|
||||
Case "ERR" & ERRPROCEDURENOTFOUND : sLocal = "Prozedur '%0' im Modul '%1' nicht gefunden"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "OBJECT" : sLocal = "Objekt"
|
||||
Case "TABLE" : sLocal = "Tabelle"
|
||||
Case "QUERY" : slocal = "Abfrage"
|
||||
Case "FORM" : sLocal = "Formular"
|
||||
Case "REPORT" : sLocal = "Report"
|
||||
Case "RECORDSET" : sLocal = "Datensatz"
|
||||
Case "FIELD" : sLocal = "Feld"
|
||||
Case "TEMPVAR" : sLocal = "Temporäre Variable"
|
||||
Case "COMMANDBAR" : sLocal = "Befehlsleiste"
|
||||
Case "COMMANDBARCONTROL" : sLocal = "Befehlsleisten-Steuerelement"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "ERR#" : sLocal = "Error #"
|
||||
Case "ERROCCUR" : sLocal = "aufgetreten"
|
||||
Case "ERRLINE" : sLocal = "in Zeile"
|
||||
Case "ERRIN" : sLocal = "in"
|
||||
Case "CALLTO" : sLocal = "ein Funktionsaufruf"
|
||||
Case "SAVECONSOLE" : sLocal = "Konsoleneingaben sichern"
|
||||
Case "SAVECONSOLEENTRIES" : sLocal = "Die Konsoleneingaben wurden erfolgreich gesichert."
|
||||
Case "QUITSHORT" : sLocal = "Beenden"
|
||||
Case "QUIT" : sLocal = "Wollen Sie wirklich die Anwendung beenden? Geänderte Daten werden gesichert."
|
||||
Case "ENTERING" : sLocal = "Beginne mit"
|
||||
Case "EXITING" : sLocal = "Verlasse"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGTRACE_HELP" : sLocal = "Verwalte den Konsolenpuffer und seine Eingaben"
|
||||
Case "DLGTRACE_TITLE" : sLocal = "Konsole"
|
||||
Case "DLGTRACE_LBLENTRIES_HELP" : sLocal = "Leere die Liste und ändere die Größe des Umlaufpuffers"
|
||||
Case "DLGTRACE_LBLENTRIES_LABEL" : sLocal = "Setze maximale Anzahl von Eingaben"
|
||||
Case "DLGTRACE_TXTTRACELOG_HELP" : sLocal = "Text kann ausgewählt, kopiert, ... werden"
|
||||
Case "DLGTRACE_TXTTRACELOG_TEXT" : sLocal = "--- Log Datei ist leer ---"
|
||||
Case "DLGTRACE_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen"
|
||||
Case "DLGTRACE_CMDCANCEL_LABEL" : sLocal = "Abbrechen"
|
||||
Case "DLGTRACE_LBLCLEAR_HELP" : sLocal = "Leere die Liste"
|
||||
Case "DLGTRACE_LBLCLEAR_LABEL" : sLocal = "Leere die Liste"
|
||||
Case "DLGTRACE_LBLMINLEVEL_HELP" : sLocal = "Registriere nur Logging-Anfragen oberhalb des gegebenen Levels"
|
||||
Case "DLGTRACE_LBLMINLEVEL_LABEL" : sLocal = "Setze minimalen Fehlerbehandlungs-Level"
|
||||
Case "DLGTRACE_CMDOK_HELP" : sLocal = "Übernehmen"
|
||||
Case "DLGTRACE_CMDOK_LABEL" : sLocal = "OK"
|
||||
Case "DLGTRACE_CMDDUMP_HELP" : sLocal = "Wähle eine Datei und speichere darin den aktuellen Listeninhalt"
|
||||
Case "DLGTRACE_CMDDUMP_LABEL" : sLocal = "Ausgabe in Datei"
|
||||
Case "DLGTRACE_LBLNBENTRIES_HELP" : sLocal = "Aktuelle Länge der Liste"
|
||||
Case "DLGTRACE_LBLNBENTRIES_LABEL" : sLocal = "Aktuelle Anzahl von Einträgen:"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case "DLGFORMAT_HELP" : sLocal = "Exportiere das Formular"
|
||||
Case "DLGFORMAT_TITLE" : sLocal = "Export"
|
||||
Case "DLGFORMAT_LBLFORMAT_HELP" : sLocal = "Format, in dem das Formular exportiert werden soll"
|
||||
Case "DLGFORMAT_LBLFORMAT_LABEL" : sLocal = "Wähle das Ausgabe-Format"
|
||||
Case "DLGFORMAT_CMDOK_HELP" : sLocal = "Auswahl übernehmen"
|
||||
Case "DLGFORMAT_CMDOK_LABEL" : sLocal = "OK"
|
||||
Case "DLGFORMAT_CMDCANCEL_HELP" : sLocal = "Abbrechen und den Dialog schließen"
|
||||
Case "DLGFORMAT_CMDCANCEL_LABEL" : sLocal = "Abbrechen"
|
||||
'----------------------------------------------------------------------------------------------------------------------
|
||||
Case Else : sLocal = _Getlabel(psShortLabel, "DEFAULT")
|
||||
End Select
|
||||
REM *******************************************************************************************************************************************
|
||||
REM *** ***
|
||||
REM *** ANY OTHER LANGUAGE TO BE INSERTED HERE ***
|
||||
REM *** ***
|
||||
REM *******************************************************************************************************************************************
|
||||
Case Else
|
||||
sLocal = _Getlabel(psShortLabel, "DEFAULT")
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
_Getlabel = sLocal
|
||||
Exit Function
|
||||
Error_Function:
|
||||
sLocal = psShortLabel
|
||||
GoTo Exit_Function
|
||||
End Function ' GetLabel V0.8.9
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _GetLabelArray(ByVal pvShortlabel As Variant, Optional ByVal psLocale As String) As Variant
|
||||
' Return the localized label corresponding with the ShortLabel array of strings
|
||||
|
||||
If IsMissing(psLocale) Then psLocale = UCase(Left(_GetLocale(), 2)) Else psLocale = UCase(psLocale)
|
||||
On Local Error Goto Error_Function
|
||||
|
||||
Dim vLocal() As Variant, i As integer
|
||||
vLocal = Array()
|
||||
|
||||
If Not IsArray(pvShortLabel) Then
|
||||
vLocal = _GetLabel(pvShortLabel, psLocale)
|
||||
Goto Exit_Function
|
||||
End If
|
||||
|
||||
ReDim vLocal(LBound(pvShortLabel) To UBound(pvShortlabel))
|
||||
For i = LBound(pvShortLabel) To UBound(pvShortlabel)
|
||||
vLocal(i) = _GetLabel(pvShortLabel(i), psLocale)
|
||||
Next i
|
||||
|
||||
Exit_Function:
|
||||
_GetlabelArray = vLocal()
|
||||
Exit Function
|
||||
Error_Function:
|
||||
vLocal = Array()
|
||||
GoTo Exit_Function
|
||||
End Function ' GetLabelArray V0.8.9
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _GetLocale() as String
|
||||
'Return OO localization
|
||||
'Derived from Tools library
|
||||
|
||||
Dim oLocale as Object
|
||||
oLocale = _GetRegistryKeyContent("org.openoffice.Setup/L10N")
|
||||
_GetLocale = oLocale.getByName("ooLocale")
|
||||
End Function ' GetLocale V0.8.9
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,300 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Methods" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function AddItem(Optional pvBox As Variant, ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean
|
||||
' Add an item in a Listbox
|
||||
|
||||
Utils._SetCalledSub("AddItem")
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
If IsMissing(pvBox) Or IsMissing(pvItem) Then Call _TraceArguments()
|
||||
If IsMissing(pvIndex) Then pvIndex = -1
|
||||
If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function
|
||||
|
||||
AddItem = pvBox.AddItem(pvItem, pvIndex)
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("AddItem")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "AddItem", Erl)
|
||||
AddItem = False
|
||||
GoTo Exit_Function
|
||||
End Function ' AddItem V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(Optional pvObject As Variant, ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if pvObject has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
Dim vPropertiesList As Variant
|
||||
|
||||
Utils._SetCalledSub("hasProperty")
|
||||
If IsMissing(pvObject) Or IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
|
||||
hasProperty = False
|
||||
If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _
|
||||
, OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _
|
||||
)) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvProperty, 2, vbString) Then Goto Exit_Function
|
||||
|
||||
hasProperty = pvObject.hasProperty(pvProperty)
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("hasProperty")
|
||||
Exit Function
|
||||
End Function ' hasProperty V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Move(Optional pvObject As Object _
|
||||
, ByVal Optional pvLeft As Variant _
|
||||
, ByVal Optional pvTop As Variant _
|
||||
, ByVal Optional pvWidth As Variant _
|
||||
, ByVal Optional pvHeight As Variant _
|
||||
) As Variant
|
||||
' Execute Move method
|
||||
Utils._SetCalledSub("Move")
|
||||
If IsMissing(pvObject) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Move = False
|
||||
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
|
||||
If IsMissing(pvLeft) Then Call _TraceArguments()
|
||||
If IsMissing(pvTop) Then pvTop = -1
|
||||
If IsMissing(pvWidth) Then pvWidth = -1
|
||||
If IsMissing(pvHeight) Then pvHeight = -1
|
||||
|
||||
Move = pvObject.Move(pvLeft, pvTop, pvWidth, pvHeight)
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Move")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Move", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Move V.0.9.1
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function OpenHelpFile()
|
||||
' Open the help file from the Help menu (IDE only)
|
||||
Const cstHelpFile = "http://www.access2base.com/access2base.html"
|
||||
|
||||
On Local Error Resume Next
|
||||
Call _ShellExecute(cstHelpFile)
|
||||
|
||||
End Function ' OpenHelpFile V0.8.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperties As Variant, oCounter As Variant, opProperty As Variant
|
||||
Dim vPropertiesList() As Variant
|
||||
|
||||
If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
|
||||
Utils._SetCalledSub("Properties")
|
||||
|
||||
Set vProperties = Nothing
|
||||
If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _
|
||||
, OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _
|
||||
)) Then Goto Exit_Function
|
||||
|
||||
If IsMissing(pvIndex) Then vProperties = pvObject.Properties Else vProperties = pvObject.Properties(pvIndex)
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperties
|
||||
Utils._ResetCalledSub("Properties")
|
||||
Exit Function
|
||||
End Function ' Properties V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Refresh(Optional pvObject As Variant) As Boolean
|
||||
' Refresh data with its most recent value in the database in a form or subform
|
||||
Utils._SetCalledSub("Refresh")
|
||||
If IsMissing(pvObject) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Refresh = False
|
||||
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
|
||||
Refresh = pvObject.Refresh()
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Refresh")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Refresh", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Refresh V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function RemoveItem(Optional pvBox As Variant,ByVal Optional pvIndex) As Boolean
|
||||
' Remove an item from a Listbox
|
||||
' Index may be a string value or an index-position
|
||||
|
||||
Utils._SetCalledSub("RemoveItem")
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
If IsMissing(pvBox) Or IsMissing(pvIndex) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function
|
||||
|
||||
RemoveItem = pvBox.RemoveItem(pvIndex)
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("RemoveItem")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "RemoveItem", Erl)
|
||||
RemoveItem = False
|
||||
GoTo Exit_Function
|
||||
End Function ' RemoveItem V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Requery(Optional pvObject As Variant) As Boolean
|
||||
' Refresh data displayed in a form, subform, combobox or listbox
|
||||
Utils._SetCalledSub("Requery")
|
||||
If IsMissing(pvObject) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL, OBJSUBFORM)) Then Goto Exit_Function
|
||||
|
||||
Requery = pvObject.Requery()
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Requery")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Requery", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Requery V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function SetFocus(Optional pvObject As Variant) As Boolean
|
||||
' Execute SetFocus method
|
||||
Utils._SetCalledSub("setFocus")
|
||||
If IsMissing(pvObject) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL)) Then Goto Exit_Function
|
||||
|
||||
SetFocus = pvObject.setFocus()
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("SetFocus")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SetFocus", Erl)
|
||||
Goto Exit_Function
|
||||
Error_Grid:
|
||||
TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name))
|
||||
Goto Exit_Function
|
||||
End Function ' SetFocus V0.9.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _OptionGroup(ByVal pvGroupName As Variant _
|
||||
, ByVal psParentType As String _
|
||||
, poComponent As Object _
|
||||
, poParent As Object _
|
||||
) As Variant
|
||||
' Return either an error or an object of type OPTIONGROUP based on its name
|
||||
|
||||
If IsMissing(pvGroupName) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Set _OptionGroup = Nothing
|
||||
|
||||
If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function
|
||||
|
||||
Dim ogGroup As Variant, i As Integer, j As Integer, bFound As Boolean
|
||||
Dim vOptionButtons() As Variant, sGroupName As String
|
||||
Dim lXY() As Long, iIndex() As Integer ' Two indexes X-Y coordinates
|
||||
Dim oView As Object, oDatabaseForm As Object, vControls As Variant
|
||||
|
||||
Const cstPixels = 10 ' Tolerance on coordinates when drawn approximately
|
||||
|
||||
bFound = False
|
||||
Select Case psParentType
|
||||
Case CTLPARENTISFORM
|
||||
'poParent is a forms collection, find the appropriate database form
|
||||
For i = 0 To poParent.Count - 1
|
||||
Set oDatabaseForm = poParent.getByIndex(i)
|
||||
If Not IsNull(oDatabaseForm) Then
|
||||
For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ?
|
||||
oDatabaseForm.getGroup(j, vOptionButtons, sGroupName)
|
||||
If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next j
|
||||
If bFound Then Exit For
|
||||
End If
|
||||
If bFound Then Exit For
|
||||
Next i
|
||||
Case CTLPARENTISSUBFORM
|
||||
'poParent is already a database form
|
||||
Set oDatabaseForm = poParent
|
||||
For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ?
|
||||
oDatabaseForm.getGroup(j, vOptionButtons, sGroupName)
|
||||
If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next j
|
||||
End Select
|
||||
|
||||
If bFound Then
|
||||
|
||||
ogGroup = New Optiongroup
|
||||
ogGroup._This = ogGroup
|
||||
ogGroup._Name = sGroupName
|
||||
ogGroup._ButtonsGroup = vOptionButtons
|
||||
ogGroup._Count = UBound(vOptionButtons) + 1
|
||||
ogGroup._ParentType = psParentType
|
||||
ogGroup._MainForm = oDatabaseForm.Name
|
||||
Set ogGroup._ParentComponent = poComponent
|
||||
|
||||
ReDim lXY(1, ogGroup._Count - 1)
|
||||
ReDim iIndex(ogGroup._Count - 1)
|
||||
For i = 0 To ogGroup._Count - 1 ' Find the position of each radiobutton
|
||||
Set oView = poComponent.CurrentController.getControl(ogGroup._ButtonsGroup(i))
|
||||
lXY(0, i) = oView.PosSize.X
|
||||
lXY(1, i) = oView.PosSize.Y
|
||||
Next i
|
||||
For i = 0 To ogGroup._Count - 1 ' Sort them on XY coordinates
|
||||
If i = 0 Then
|
||||
iIndex(0) = 0
|
||||
Else
|
||||
iIndex(i) = i
|
||||
For j = i - 1 To 0 Step -1
|
||||
If lXY(1, i) - lXY(1, j) < - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) <= cstPixels And lXY(0, i) - lXY(0, j) < - cstPixels ) Then
|
||||
iIndex(i) = iIndex(j)
|
||||
iIndex(j) = iIndex(j) + 1
|
||||
End If
|
||||
Next j
|
||||
End If
|
||||
Next i
|
||||
ogGroup._ButtonsIndex = iIndex()
|
||||
|
||||
Set _OptionGroup = ogGroup
|
||||
|
||||
Else
|
||||
|
||||
Set _OptionGroup = Nothing
|
||||
TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName))
|
||||
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err,"_OptionGroup", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' _OptionGroup V1.1.0
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,722 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Module" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be MODULE
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _Library As Object ' com.sun.star.container.XNameAccess
|
||||
Private _LibraryName As String
|
||||
Private _Storage As String ' GLOBAL or DOCUMENT
|
||||
Private _Script As String ' Full script (string with vbLf's)
|
||||
Private _Lines As Variant ' Array of script lines
|
||||
Private _CountOfLines As Long
|
||||
Private _ProcsParsed As Boolean ' To test before use of proc arrays
|
||||
Private _ProcNames() As Variant ' All procedure names
|
||||
Private _ProcDecPositions() As Variant ' All procedure declarations
|
||||
Private _ProcEndPositions() As Variant ' All end procedure statements
|
||||
Private _ProcTypes() As Variant ' One of the vbext_pk_* constants
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJMODULE
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
Set _Library = Nothing
|
||||
_LibraryName = ""
|
||||
_Storage = ""
|
||||
_Script = ""
|
||||
_Lines = Array()
|
||||
_CountOfLines = 0
|
||||
_ProcsParsed = False
|
||||
_ProcNames = Array()
|
||||
_ProcDecPositions = Array()
|
||||
_ProcEndPositions = Array()
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get CountOfDeclarationLines() As Long
|
||||
CountOfDeclarationLines = _PropertyGet("CountOfDeclarationLines")
|
||||
End Property ' CountOfDeclarationLines (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get CountOfLines() As Long
|
||||
CountOfLines = _PropertyGet("CountOfLines")
|
||||
End Property ' CountOfLines (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Lines(Optional ByVal pvLine As Variant, Optional ByVal pvNumLines As Variant) As String
|
||||
' Returns a string containing the contents of a specified line or lines in a standard module or a class module
|
||||
|
||||
Const cstThisSub = "Module.Lines"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim sLines As String, lLine As Long
|
||||
sLines = ""
|
||||
|
||||
If IsMissing(pvLine) Or IsMissing(pvNumLines) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
|
||||
If Not Utils._CheckArgument(pvNumLines, 1, _AddNumeric()) Then GoTo Exit_Function
|
||||
|
||||
lLine = pvLine
|
||||
Do While lLine < _CountOfLines And lLine < pvLine + pvNumLines
|
||||
sLines = sLines & _Lines(lLine - 1) & vbLf
|
||||
lLine = lLine + 1
|
||||
Loop
|
||||
If Len(sLines) > 0 Then sLines = Left(sLines, Len(sLines) - 1)
|
||||
|
||||
Exit_Function:
|
||||
Lines = sLines
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' Lines
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function ProcBodyLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
|
||||
' Return the number of the line at which the body of a specified procedure begins
|
||||
|
||||
Const cstThisSub = "Module.ProcBodyLine"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim iIndex As Integer
|
||||
|
||||
If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
|
||||
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
|
||||
|
||||
iIndex = _FindProcIndex(pvProc, pvProcType)
|
||||
If iIndex >= 0 Then ProcBodyLine = _LineOfPosition(_ProcDecPositions(iIndex)) Else ProcBodyLine = iIndex
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' ProcBodyline
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function ProcCountLines(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
|
||||
' Return the number of lines in the specified procedure
|
||||
|
||||
Const cstThisSub = "Module.ProcCountLines"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim iIndex As Integer, lStart As Long, lEnd As Long
|
||||
|
||||
If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
|
||||
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
|
||||
|
||||
iIndex = _FindProcIndex(pvProc, pvProcType)
|
||||
lStart = ProcStartLine(pvProc, pvProcType)
|
||||
lEnd = _LineOfPosition(_ProcEndPositions(iIndex))
|
||||
ProcCountLines = lEnd - lStart + 1
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' ProcCountLines
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function ProcOfLine(Optional ByVal pvLine As Variant, Optional ByRef pvProcType As Variant) As String
|
||||
' Return the name and type of the procedure containing line pvLine
|
||||
|
||||
Const cstThisSub = "Module.ProcOfLine"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim sProcedure As String, iProc As Integer, lLineDec As Long, lLineEnd As Long
|
||||
|
||||
If IsMissing(pvLine) Or IsMissing(pvProcType) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
|
||||
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
|
||||
|
||||
If Not _ProcsParsed Then _ParseProcs()
|
||||
|
||||
sProcedure = ""
|
||||
For iProc = 0 To UBound(_ProcNames)
|
||||
lLineEnd = _LineOfPosition(_ProcEndPositions(iProc))
|
||||
If pvLine <= lLineEnd Then
|
||||
lLineDec = _LineOfPosition(_ProcDecPositions(iProc))
|
||||
If pvLine < lLineDec Then ' Line between 2 procedures
|
||||
sProcedure = ""
|
||||
Else
|
||||
sProcedure = _ProcNames(iProc)
|
||||
pvProcType = _ProcTypes(iProc)
|
||||
End If
|
||||
Exit For
|
||||
End If
|
||||
Next iProc
|
||||
|
||||
Exit_Function:
|
||||
ProcOfLine = sProcedure
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' ProcOfline
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function ProcStartLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
|
||||
' Return the number of the line at which the specified procedure begins
|
||||
|
||||
Const cstThisSub = "Module.ProcStartLine"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim lLine As Long, lIndex As Long, sLine As String
|
||||
|
||||
If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
|
||||
If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
|
||||
|
||||
lLine = ProcBodyLine(pvProc, pvProcType)
|
||||
' Search baclIndexward for comment lines
|
||||
lIndex = lLine - 1
|
||||
Do While lIndex > 0
|
||||
sLine = _Trim(_Lines(lIndex - 1))
|
||||
If UCase(Left(sLine, 4)) = "REM " Or Left(sLine, 1) = "'" Then
|
||||
lLine = lIndex
|
||||
Else
|
||||
Exit Do
|
||||
End If
|
||||
lIndex = lIndex - 1
|
||||
Loop
|
||||
|
||||
ProcStartLine = lLine
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' ProcStartLine
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Const cstThisSub = "Module.Properties"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get pType() As String
|
||||
pType = _PropertyGet("Type")
|
||||
End Property ' Type (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Find(Optional ByVal pvTarget As Variant _
|
||||
, Optional ByRef pvStartLine As Variant _
|
||||
, Optional ByRef pvStartColumn As Variant _
|
||||
, Optional ByRef pvEndLine As Variant _
|
||||
, Optional ByRef pvEndColumn As Variant _
|
||||
, Optional ByVal pvWholeWord As Boolean _
|
||||
, Optional ByVal pvMatchCase As Boolean _
|
||||
, Optional ByVal pvPatternSearch As Boolean _
|
||||
) As Boolean
|
||||
' Finds specified text in the module
|
||||
' xxLine and xxColumn arguments are mainly to return the position of the found string
|
||||
' If they are initialized but nonsense, the function returns False
|
||||
|
||||
Const cstThisSub = "Module.Find"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Dim bFound As Boolean, lPosition As Long, lStartLine As Long, lStartColumn As Long, lStartPosition As Long
|
||||
Dim lEndLine As Long, lEndColumn As Long, lEndPosition As Long
|
||||
Dim sMatch As String, vOptions As Variant, sPattern As String
|
||||
Dim i As Integer, sSpecChar As String
|
||||
|
||||
Const cstSpecialCharacters = "\[^$.|?*+()"
|
||||
|
||||
bFound = False
|
||||
|
||||
If IsMissing(pvTarget) Or IsMissing(pvStartLine) Or IsMissing(pvStartColumn) Or IsMissing(pvEndLine) Or IsMissing(pvEndColumn) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvTarget, 1, vbString) Then GoTo Exit_Function
|
||||
If Len(pvTarget) = 0 Then GoTo Exit_Function
|
||||
If Not IsEmpty(pvStartLine) Then
|
||||
If Not Utils._CheckArgument(pvStartLine, 2, _AddNumeric()) Then GoTo Exit_Function
|
||||
End If
|
||||
If Not IsEmpty(pvStartColumn) Then
|
||||
If Not Utils._CheckArgument(pvStartColumn, 3, _AddNumeric()) Then GoTo Exit_Function
|
||||
End If
|
||||
If Not IsEmpty(pvEndLine) Then
|
||||
If Not Utils._CheckArgument(pvEndLine, 4, _AddNumeric()) Then GoTo Exit_Function
|
||||
End If
|
||||
If Not IsEmpty(pvEndColumn) Then
|
||||
If Not Utils._CheckArgument(pvEndColumn, 5, _AddNumeric()) Then GoTo Exit_Function
|
||||
End If
|
||||
If IsMissing(pvWholeWord) Then pvWholeWord = False
|
||||
If Not Utils._CheckArgument(pvWholeWord, 6, vbBoolean) Then GoTo Exit_Function
|
||||
If IsMissing(pvMatchCase) Then pvMatchCase = False
|
||||
If Not Utils._CheckArgument(pvMatchCase, 7, vbBoolean) Then GoTo Exit_Function
|
||||
If IsMissing(pvPatternSearch) Then pvPatternSearch = False
|
||||
If Not Utils._CheckArgument(pvPatternSearch, 8, vbBoolean) Then GoTo Exit_Function
|
||||
|
||||
' Initialize starting values
|
||||
If IsEmpty(pvStartLine) Then lStartLine = 1 Else lStartLine = pvStartLine
|
||||
If lStartLine <= 0 Or lStartLine > UBound(_Lines) + 1 Then GoTo Exit_Function
|
||||
If IsEmpty(pvStartColumn) Then lStartColumn = 1 Else lStartColumn = pvStartColumn
|
||||
If lStartColumn <= 0 Then GoTo Exit_Function
|
||||
If lStartColumn > 1 And lStartColumn > Len(_Lines(lStartLine + 1)) Then GoTo Exit_Function
|
||||
lStartPosition = _PositionOfLine(lStartline) + lStartColumn - 1
|
||||
If IsEmpty(pvEndLine) Then lEndLine = UBound(_Lines) + 1 Else lEndLine = pvEndLine
|
||||
If lEndLine < lStartLine Or lEndLine > UBound(_Lines) + 1 Then GoTo Exit_Function
|
||||
If IsEmpty(pvEndColumn) Then lEndColumn = Len(_Lines(lEndLine - 1)) Else lEndColumn = pvEndColumn
|
||||
If lEndColumn < 0 Then GoTo Exit_Function
|
||||
If lEndColumn = 0 Then lEndColumn = 1
|
||||
If lEndColumn > Len(_Lines(lEndLine - 1)) + 1 Then GoTo Exit_Function
|
||||
lEndPosition = _PositionOfLine(lEndline) + lEndColumn - 1
|
||||
|
||||
If pvMatchCase Then
|
||||
Set vOptions = _A2B_.SearchOptions
|
||||
vOptions.transliterateFlags = 0
|
||||
End If
|
||||
|
||||
' Define pattern to search for
|
||||
sPattern = pvTarget
|
||||
' Protect special characters in regular expressions
|
||||
For i = 1 To Len(cstSpecialCharacters)
|
||||
sSpecChar = Mid(cstSpecialCharacters, i, 1)
|
||||
sPattern = Replace(sPattern, sSpecChar, "\" & sSpecChar)
|
||||
Next i
|
||||
If pvPatternSearch Then sPattern = Replace(Replace(sPattern, "\*", ".*"), "\?", ".")
|
||||
If pvWholeWord Then sPattern = "\b" & sPattern & "\b"
|
||||
|
||||
lPosition = lStartPosition
|
||||
sMatch = Utils._RegexSearch(_Script, sPattern, lPosition)
|
||||
' Re-establish default options for later searches
|
||||
If pvMatchCase Then vOptions.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
|
||||
|
||||
' Found within requested bounds ?
|
||||
If sMatch <> "" And lPosition >= lStartPosition And lPosition <= lEndPosition Then
|
||||
pvStartLine = _LineOfPosition(lPosition)
|
||||
pvStartColumn = lPosition - _PositionOfLine(pvStartLine) + 1
|
||||
pvEndLine = _LineOfPosition(lPosition + Len(sMatch) - 1)
|
||||
If pvEndLine > pvStartLine Then
|
||||
pvEndColumn = lPosition + Len(sMatch) - 1 - _PositionOfLine(pvEndLine)
|
||||
Else
|
||||
pvEndColumn = pvStartColumn + Len(sMatch) - 1
|
||||
End If
|
||||
bFound = True
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Find = bFound
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Module.Find", Erl)
|
||||
bFound = False
|
||||
GoTo Exit_Function
|
||||
End Function ' Find
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Const cstThisSub = "Module.Properties"
|
||||
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM --------------------------------Mid(a._Script, iCtl, 25)---------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
Const cstThisSub = "Module.hasProperty"
|
||||
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _BeginStatement(ByVal plStart As Long) As Long
|
||||
' Return the position in _Script of the beginning of the current statement as defined by plStart
|
||||
|
||||
Dim sProc As String, iProc As Integer, iType As Integer
|
||||
Dim lPosition As Long, lPrevious As Long, sFind As String
|
||||
|
||||
sProc = ProcOfLine(_LineOfPosition(plStart), iType)
|
||||
iProc = _FindProcIndex(sProc, iType)
|
||||
If iProc < 0 Then lPosition = 1 Else lPosition = _ProcDecPositions(iProc)
|
||||
|
||||
sFind = "Any"
|
||||
Do While lPosition < plStart And sFind <> ""
|
||||
lPrevious = lPosition
|
||||
sFind = _FindPattern("%^\w", lPosition)
|
||||
If sFind = "" Then Exit Do
|
||||
Loop
|
||||
|
||||
_BeginStatement = lPrevious
|
||||
|
||||
End Function ' _EndStatement
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _EndStatement(ByVal plStart As Long) As Long
|
||||
' Return the position in _Script of the end of the current statement as defined by plStart
|
||||
' plStart is assumed not to be in the middle of a comment or a string
|
||||
|
||||
Dim sMatch As String, lPosition As Long
|
||||
lPosition = plStart
|
||||
sMatch = _FindPattern("%$", lPosition)
|
||||
_EndStatement = lPosition
|
||||
|
||||
End Function ' _EndStatement
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _FindPattern(ByVal psPattern As Variant, Optional ByRef plStart As Long) As String
|
||||
' Find first occurrence of any of the patterns in |-delimited string psPattern
|
||||
' Special escapes
|
||||
' - for word breaks: "%B" (f.i. for searching "END%BFUNCTION")
|
||||
' - for statement start: "%^" (f.i. for searching "%^END%BFUNCTION"). Necessarily first 2 characters of pattern
|
||||
' - for statement end: "%$". Pattern should not contain anything else
|
||||
' If quoted string searched, pattern should start and end with a double quote
|
||||
' Return "" if none found, otherwise returns the matching string
|
||||
' plStart = start position of _Script to search (starts at 1)
|
||||
' In output plStart contains the first position of the matching string or is left unchanged
|
||||
' To search again the same or another pattern => plStart = plStart + Len(matching string)
|
||||
' Comments and strings are skipped
|
||||
|
||||
' Common patterns
|
||||
Const cstComment = "('|\bREM\b)[^\n]*$"
|
||||
Const cstString = """[^""\n]*"""
|
||||
Const cstBeginStatement = "(^|:|\bthen\b|\belse\b|\n)[ \t]*"
|
||||
Const cstEndStatement = "[ \t]*($|:|\bthen\b|\belse\b|\n)"
|
||||
Const cstContinuation = "[ \t]_\n"
|
||||
Const cstWordBreak = "\b[ \t]+(_\n[ \t]*)?\b"
|
||||
Const cstAlt = "|"
|
||||
|
||||
Dim sRegex As String, lStart As Long, bContinue As Boolean, sMatch As String
|
||||
Dim bEndStatement As Boolean, bQuote As Boolean
|
||||
|
||||
If psPattern = "%$" Then
|
||||
sRegex = cstEndStatement
|
||||
Else
|
||||
sRegex = psPattern
|
||||
If Left(psPattern, 2) = "%^" Then sRegex = cstBeginStatement & Right(sRegex, Len(sregex) - 2)
|
||||
sregex = Replace(sregex, "%B", cstWordBreak)
|
||||
End If
|
||||
' Add all to ignore patterns to regex. If pattern = quoted string do not add cstString
|
||||
If Len(psPattern) > 2 And Left(psPattern, 1) = """" And Right(psPattern, 1) = """" Then
|
||||
bQuote = True
|
||||
sRegex = sRegex & cstAlt & cstComment & cstAlt & cstContinuation
|
||||
Else
|
||||
bQuote = False
|
||||
sRegex = sRegex & cstAlt & cstComment & cstAlt & cstString & cstAlt & cstContinuation
|
||||
End If
|
||||
|
||||
If IsMissing(plStart) Then plStart = 1
|
||||
lStart = plStart
|
||||
|
||||
bContinue = True
|
||||
Do While bContinue
|
||||
bEndStatement = False
|
||||
sMatch = Utils._RegexSearch(_Script, sRegex, lStart)
|
||||
Select Case True
|
||||
Case sMatch = ""
|
||||
bContinue = False
|
||||
Case Left(sMatch, 1) = "'"
|
||||
bEndStatement = True
|
||||
Case Left(sMatch, 1) = """"
|
||||
If bQuote Then
|
||||
plStart = lStart
|
||||
bContinue = False
|
||||
End If
|
||||
Case Left(smatch, 1) = ":" Or Left(sMatch, 1) = vbLf
|
||||
If psPattern = "%$" Then
|
||||
bEndStatement = True
|
||||
Else
|
||||
bContinue = False
|
||||
plStart = lStart + 1
|
||||
sMatch = Right(sMatch, Len(sMatch) - 1)
|
||||
End If
|
||||
Case UCase(Left(sMatch, 4)) = "REM " Or UCase(Left(sMatch, 4)) = "REM" & vbTab Or UCase(Left(sMatch, 4)) = "REM" & vbNewLine
|
||||
bEndStatement = True
|
||||
Case UCase(Left(sMatch, 4)) = "THEN" Or UCase(Left(sMatch, 4)) = "ELSE"
|
||||
If psPattern = "%$" Then
|
||||
bEndStatement = True
|
||||
Else
|
||||
bContinue = False
|
||||
plStart = lStart + 4
|
||||
sMatch = Right(sMatch, Len(sMatch) - 4)
|
||||
End If
|
||||
Case sMatch = " _" & vbLf
|
||||
Case Else ' Found
|
||||
plStart = lStart
|
||||
bContinue = False
|
||||
End Select
|
||||
If bEndStatement And psPattern = "%$" Then
|
||||
bContinue = False
|
||||
plStart = lStart - 1
|
||||
sMatch = ""
|
||||
End If
|
||||
lStart = lStart + Len(sMatch)
|
||||
Loop
|
||||
|
||||
_FindPattern = sMatch
|
||||
|
||||
End Function ' _FindPattern
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _FindProcIndex(ByVal psProc As String, ByVal piType As Integer) As Integer
|
||||
' Return index of entry in _Procnames corresponding with pvProc
|
||||
|
||||
Dim i As Integer, iIndex As Integer
|
||||
|
||||
If Not _ProcsParsed Then _ParseProcs
|
||||
|
||||
iIndex = -1
|
||||
For i = 0 To UBound(_ProcNames)
|
||||
If UCase(psProc) = UCase(_ProcNames(i)) And piType = _ProcTypes(i) Then
|
||||
iIndex = i
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
If iIndex < 0 Then TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, Utils._CalledSub(), 0, , Array(psProc, _Name))
|
||||
|
||||
Exit_Function:
|
||||
_FindProcIndex = iIndex
|
||||
Exit Function
|
||||
End Function ' _FindProcIndex
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub _Initialize()
|
||||
|
||||
_Script = Replace(_Script, vbCr, "")
|
||||
_Lines = Split(_Script, vbLf)
|
||||
_CountOfLines = UBound(_Lines) + 1
|
||||
|
||||
End Sub ' _Initialize
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _LineOfPosition(ByVal plPosition) As Long
|
||||
' Return the line number of a position in _Script
|
||||
|
||||
Dim lLine As Long, lLength As Long
|
||||
' Start counting from start or end depending on how close position is
|
||||
If plPosition <= Len(_Script) / 2 Then
|
||||
lLength = 0
|
||||
For lLine = 0 To UBound(_Lines)
|
||||
lLength = lLength + Len(_Lines(lLine)) + 1 ' + 1 for line feed
|
||||
If lLength >= plPosition Then
|
||||
_LineOfPosition = lLine + 1
|
||||
Exit Function
|
||||
End If
|
||||
Next lLine
|
||||
Else
|
||||
If Right(_Script, 1) = vbLf Then lLength = Len(_Script) + 1 Else lLength = Len(_Script)
|
||||
For lLine = UBound(_Lines) To 0 Step -1
|
||||
lLength = lLength - Len(_Lines(lLine)) - 1 ' - 1 for line feed
|
||||
If lLength <= plPosition Then
|
||||
_LineOfPosition = lLine + 1
|
||||
Exit Function
|
||||
End If
|
||||
Next lLine
|
||||
End If
|
||||
|
||||
End Function ' _LineOfPosition
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub _ParseProcs()
|
||||
' Fills the Proc arrays: name, start and end position
|
||||
' Executed at first request needing this processing
|
||||
|
||||
Dim lPosition As Long, iProc As Integer, sDecProc As String, sEndProc As String, sNameProc As String, sType As String
|
||||
Const cstDeclaration = "%^(private%B|public%B)?\b(property%Bget|property%Blet|property%Bset|function|sub)\b"
|
||||
Const cstEnd = "%^end%B(property|function|sub)\b"
|
||||
Const cstName = "\w*" '"[A-Za-z_][A-Za-z_0-9]*"
|
||||
|
||||
If _ProcsParsed Then Exit Sub ' Do not redo if already done
|
||||
_ProcNames = Array()
|
||||
_ProcDecPositions = Array()
|
||||
_ProcEndPositions = Array()
|
||||
_ProcTypes = Array()
|
||||
|
||||
lPosition = 1
|
||||
iProc = -1
|
||||
sDecProc = "???"
|
||||
Do While sDecProc <> ""
|
||||
' Identify Function/Sub declaration string
|
||||
sDecProc = _FindPattern(cstDeclaration, lPosition)
|
||||
If sDecProc <> "" Then
|
||||
iProc = iProc + 1
|
||||
ReDim Preserve _ProcNames(0 To iProc)
|
||||
ReDim Preserve _ProcDecPositions(0 To iProc)
|
||||
ReDim Preserve _ProcEndPositions(0 To iProc)
|
||||
ReDim Preserve _ProcTypes(0 To iProc)
|
||||
_ProcDecPositions(iProc) = lPosition
|
||||
lPosition = lPosition + Len(sDecProc)
|
||||
' Identify procedure type
|
||||
Select Case True
|
||||
Case InStr(UCase(sDecProc), "FUNCTION") > 0 : _ProcTypes(iProc) = vbext_pk_Proc
|
||||
Case InStr(UCase(sDecProc), "SUB") > 0 : _ProcTypes(iProc) = vbext_pk_Proc
|
||||
Case InStr(UCase(sDecProc), "GET") > 0 : _ProcTypes(iProc) = vbext_pk_Get
|
||||
Case InStr(UCase(sDecProc), "LET") > 0 : _ProcTypes(iProc) = vbext_pk_Let
|
||||
Case InStr(UCase(sDecProc), "SET") > 0 : _ProcTypes(iProc) = vbext_pk_Set
|
||||
End Select
|
||||
' Identify name of Function/Sub
|
||||
sNameProc = _FindPattern(cstName, lPosition)
|
||||
If sNameProc = "" Then Exit Do ' Should never happen
|
||||
_ProcNames(iProc) = sNameProc
|
||||
lPosition = lPosition + Len(sNameProc)
|
||||
' Identify End statement
|
||||
sEndProc = _FindPattern(cstEnd, lPosition)
|
||||
If sEndProc = "" Then Exit Do ' Should never happen
|
||||
_ProcEndPositions(iProc) = lPosition
|
||||
lPosition = lPosition + Len(sEndProc)
|
||||
End If
|
||||
Loop
|
||||
|
||||
_ProcsParsed = True
|
||||
|
||||
End Sub
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PositionOfLine(ByVal plLine) As Long
|
||||
' Return the position of the first character of the given line in _Script
|
||||
|
||||
Dim lLine As Long, lPosition As Long
|
||||
' Start counting from start or end depending on how close line is
|
||||
If plLine <= (UBound(_Lines) + 1) / 2 Then
|
||||
lPosition = 0
|
||||
For lLine = 0 To plLine - 1
|
||||
lPosition = lPosition + 1 ' + 1 for line feed
|
||||
If lLine < plLine - 1 Then lPosition = lPosition + Len(_Lines(lLine))
|
||||
Next lLine
|
||||
Else
|
||||
lPosition = Len(_Script) + 2 ' Anticipate an ending null-string and a line feed
|
||||
For lLine = UBound(_Lines) To plLine - 1 Step -1
|
||||
lPosition = lPosition - Len(_Lines(lLine)) - 1 ' - 1 for line feed
|
||||
Next lLine
|
||||
End If
|
||||
|
||||
_PositionOfLine = lPosition
|
||||
|
||||
End Function ' _LineOfPosition
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
_PropertiesList = Array("CountOfDeclarationLines", "CountOfLines", "Name", "ObjectType", "Type")
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
Dim cstThisSub As String
|
||||
Const cstDot = "."
|
||||
|
||||
Dim sText As String
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
cstThisSub = "Module.get" & psProperty
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
_PropertyGet = Null
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("CountOfDeclarationLines")
|
||||
If Not _ProcsParsed Then _ParseProcs()
|
||||
If UBound(_ProcNames) >= 0 Then
|
||||
_PropertyGet = ProcStartLine(_ProcNames(0), _ProcTypes(0)) - 1
|
||||
Else
|
||||
_PropertyGet = _CountOfLines
|
||||
End If
|
||||
Case UCase("CountOfLines")
|
||||
_PropertyGet = _CountOfLines
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Storage & cstDot & _LibraryName & cstDot & _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Type")
|
||||
' Find option statement before any procedure declaration
|
||||
sText = _FindPattern("%^option%Bclassmodule\b|\bfunction\b|\bsub\b|\bproperty\b")
|
||||
If UCase(Left(sText, 6)) = "OPTION" Then _PropertyGet = acClassModule Else _PropertyGet = acStandardModule
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Module._PropertyGet", Erl)
|
||||
_PropertyGet = Null
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,315 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="OptionGroup" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be FORM
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _ParentType As String
|
||||
Private _ParentComponent As Object
|
||||
Private _MainForm As String
|
||||
Private _DocEntry As Integer
|
||||
Private _DbEntry As Integer
|
||||
Private _ButtonsGroup() As Variant
|
||||
Private _ButtonsIndex() As Variant
|
||||
Private _Count As Long
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJOPTIONGROUP
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
_ParentType = ""
|
||||
_ParentComponent = Nothing
|
||||
_DocEntry = -1
|
||||
_DbEntry = -1
|
||||
_ButtonsGroup = Array()
|
||||
_ButtonsIndex = Array()
|
||||
_Count = 0
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Count() As Variant
|
||||
Count = _PropertyGet("Count")
|
||||
End Property ' Count (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
Public Function pName() As String ' For compatibility with < V0.9.0
|
||||
pName = _PropertyGet("Name")
|
||||
End Function ' pName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Value() As Variant
|
||||
Value = _PropertyGet("Value")
|
||||
End Property ' Value (get)
|
||||
|
||||
Property Let Value(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Value", pvValue)
|
||||
End Property ' Value (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
|
||||
' Return a Control object with name or index = pvIndex
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("OptionGroup.Controls")
|
||||
|
||||
Dim ocControl As Variant, iArgNr As Integer, i As Integer
|
||||
Dim oCounter As Object
|
||||
|
||||
Set ocControl = Nothing
|
||||
|
||||
If IsMissing(pvIndex) Then ' No argument, return Collection object
|
||||
Set oCounter = New Collect
|
||||
Set oCounter._This = oCounter
|
||||
oCounter._CollType = COLLCONTROLS
|
||||
Set oCounter._Parent = _This
|
||||
oCounter._Count = _Count
|
||||
Set Controls = oCounter
|
||||
Goto Exit_Function
|
||||
End If
|
||||
|
||||
If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2
|
||||
If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If pvIndex < 0 Or pvIndex > _Count - 1 Then Goto Trace_Error_Index
|
||||
|
||||
' Start building the ocControl object
|
||||
' Determine exact name
|
||||
Set ocControl = New Control
|
||||
Set ocControl._This = ocControl
|
||||
Set ocControl._Parent = _This
|
||||
ocControl._ParentType = CTLPARENTISGROUP
|
||||
|
||||
ocControl._Shortcut = ""
|
||||
For i = 0 To _Count - 1
|
||||
If _ButtonsIndex(i) = pvIndex Then
|
||||
Set ocControl.ControlModel = _ButtonsGroup(i)
|
||||
Select Case _ParentType
|
||||
Case CTLPARENTISDIALOG : ocControl._Name = _ButtonsGroup(i).Name
|
||||
Case Else : ocControl._Name = _Name ' OptionGroup and individual radio buttons share the same name
|
||||
End Select
|
||||
ocControl._ImplementationName = ocControl.ControlModel.getImplementationName()
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
ocControl._FormComponent = _ParentComponent
|
||||
ocControl._ClassId = acRadioButton
|
||||
Select Case _ParentType
|
||||
Case CTLPARENTISDIALOG : Set ocControl.ControlView = _ParentComponent.getControl(ocControl._Name)
|
||||
Case Else : Set ocControl.ControlView = _ParentComponent.CurrentController.getControl(ocControl.ControlModel)
|
||||
End Select
|
||||
|
||||
ocControl._Initialize()
|
||||
ocControl._DocEntry = _DocEntry
|
||||
ocControl._DbEntry = _DbEntry
|
||||
Set Controls = ocControl
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("OptionGroup.Controls")
|
||||
Exit Function
|
||||
Trace_Error_Index:
|
||||
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "OptionGroup.Controls", Erl)
|
||||
Set Controls = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' Controls
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("OptionGroup.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("OptionGroup.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Utils._SetCalledSub("OptionGroup.setProperty")
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub("OptionGroup.setProperty")
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
_PropertiesList = Array("Count", "Name", "ObjectType", "Value")
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("OptionGroup.get" & psProperty)
|
||||
|
||||
'Execute
|
||||
Dim oDatabase As Object, vBookmark As Variant
|
||||
Dim iValue As Integer, i As Integer
|
||||
_PropertyGet = EMPTY
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Count")
|
||||
_PropertyGet = _Count
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Value")
|
||||
iValue = -1
|
||||
For i = 0 To _Count - 1 ' Find the selected RadioButton
|
||||
If _ButtonsGroup(i).State = 1 Then
|
||||
iValue = _ButtonsIndex(i)
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
_PropertyGet = iValue
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("OptionGroup.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Trace_Error_Index:
|
||||
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "OptionGroup._PropertyGet", Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
|
||||
Utils._SetCalledSub("OptionGroup.set" & psProperty)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
_PropertySet = True
|
||||
|
||||
'Execute
|
||||
Dim i As Integer, iRadioIndex As Integer, oModel As Object, iArgNr As Integer
|
||||
|
||||
If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Value")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
If pvValue < 0 Or pvValue > _Count - 1 Then Goto Trace_Error_Value
|
||||
For i = 0 To _Count - 1
|
||||
_ButtonsGroup(i).State = 0
|
||||
If _ButtonsIndex(i) = pvValue Then iRadioIndex = i
|
||||
Next i
|
||||
_ButtonsGroup(iRadioIndex).State = 1
|
||||
Set oModel = _ButtonsGroup(iRadioIndex)
|
||||
If Utils._hasUNOProperty(oModel, "DataField") Then
|
||||
If Not IsNull(oModel.Datafield) And Not IsEmpty(oModel.Datafield) Then
|
||||
If oModel.Datafield <> "" And Utils._hasUNOMethod(oModel, "commit") Then oModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM]
|
||||
End If
|
||||
End If
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("OptionGroup.set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "OptionGroup._PropertySet", Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,577 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="PropertiesSet" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setAbsolutePosition(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAbsolutePosition")
|
||||
setAbsolutePosition = PropertiesSet._setProperty(pvObject, "AbsolutePosition", pvValue)
|
||||
End Function ' setAbsolutePosition
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setAllowAdditions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowAdditions")
|
||||
setAllowAdditions = PropertiesSet._setProperty(pvObject, "AllowAdditions", pvValue)
|
||||
End Function ' setAllowAdditions
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setAllowDeletions(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowDeletions")
|
||||
setAllowDeletions = PropertiesSet._setProperty(pvObject, "AllowDeletions", pvValue)
|
||||
End Function ' setAllowDeletions
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setAllowEdits(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setAllowEdits")
|
||||
setAllowEdits = PropertiesSet._setProperty(pvObject, "AllowEdits", pvValue)
|
||||
End Function ' setAllowEdits
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setBackColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBackColor")
|
||||
setBackColor = PropertiesSet._setProperty(pvObject, "BackColor", pvValue)
|
||||
End Function ' setBackColor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setBookmark(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBookmark")
|
||||
setBookmark = PropertiesSet._setProperty(pvObject, "Bookmark", pvValue)
|
||||
End Function ' setBookmark
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setBorderColor (Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderColor")
|
||||
setBorderColor = PropertiesSet._setProperty(pvObject, "BorderColor", pvValue)
|
||||
End Function ' setBorderColor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setBorderStyle(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setBorderStyle")
|
||||
setBorderStyle = PropertiesSet._setProperty(pvObject, "BorderStyle", pvValue)
|
||||
End Function ' setBorderStyle
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setCancel(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCancel")
|
||||
setCancel = PropertiesSet._setProperty(pvObject, "Cancel", pvValue)
|
||||
End Function ' setCancel
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setCaption(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCaption")
|
||||
setCaption = PropertiesSet._setProperty(pvObject, "Caption", pvValue)
|
||||
End Function ' setCaption
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setControlTipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setControlTipText")
|
||||
setControlTipText = PropertiesSet._setProperty(pvObject, "ControlTipText", pvValue)
|
||||
End Function ' setControlTipText
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setCurrentRecord(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setCurrentRecord")
|
||||
setCurrentRecord = PropertiesSet._setProperty(pvObject, "CurrentRecord", pvValue)
|
||||
End Function ' setCurrentRecord
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setDefault(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefault")
|
||||
setDefault = PropertiesSet._setProperty(pvObject, "Default", pvValue)
|
||||
End Function ' setDefault
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setDefaultValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDefaultValue")
|
||||
setDefaultValue = PropertiesSet._setProperty(pvObject, "DefaultValue", pvValue)
|
||||
End Function ' setDefaultValue
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setDescription(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDescription")
|
||||
setDescription = PropertiesSet._setProperty(pvObject, "Description", pvValue)
|
||||
End Function ' setDescription
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setEnabled(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setEnabled")
|
||||
setEnabled = PropertiesSet._setProperty(pvObject, "Enabled", pvValue)
|
||||
End Function ' setEnabled
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFilter(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilter")
|
||||
setFilter = PropertiesSet._setProperty(pvObject, "Filter", pvValue)
|
||||
End Function ' setFilter
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFilterOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFilterOn")
|
||||
setFilterOn = PropertiesSet._setProperty(pvObject, "FilterOn", pvValue)
|
||||
End Function ' setFilterOn
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFontBold(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontBold")
|
||||
setFontBold = PropertiesSet._setProperty(pvObject, "FontBold", pvValue)
|
||||
End Function ' setFontBold
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFontItalic(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontItalic")
|
||||
setFontItalic = PropertiesSet._setProperty(pvObject, "FontItalic", pvValue)
|
||||
End Function ' setFontItalic
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFontName(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontName")
|
||||
setFontName = PropertiesSet._setProperty(pvObject, "FontName", pvValue)
|
||||
End Function ' setFontName
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFontSize(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontSize")
|
||||
setFontSize = PropertiesSet._setProperty(pvObject, "FontSize", pvValue)
|
||||
End Function ' setFontSize
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFontUnderline(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontUnderline")
|
||||
setFontUnderline = PropertiesSet._setProperty(pvObject, "FontUnderline", pvValue)
|
||||
End Function ' setFontUnderline
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setFontWeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setFontWeight")
|
||||
setFontWeight = PropertiesSet._setProperty(pvObject, "FontWeight", pvValue)
|
||||
End Function ' setFontWeight
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setForeColor(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setForeColor")
|
||||
setForeColor = PropertiesSet._setProperty(pvObject, "ForeColor", pvValue)
|
||||
End Function ' setForeColor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setHeight(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setHeight")
|
||||
setHeight = PropertiesSet._setProperty(pvObject, "Height", pvValue)
|
||||
End Function ' setHeight
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setListIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setListIndex")
|
||||
setListIndex = PropertiesSet._setProperty(pvObject, "ListIndex", pvValue)
|
||||
End Function ' setListIndex
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setLocked(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setLocked")
|
||||
setLocked = PropertiesSet._setProperty(pvObject, "Locked", pvValue)
|
||||
End Function ' setLocked
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setMultiSelect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setMultiSelect")
|
||||
setMultiSelect = PropertiesSet._setProperty(pvObject, "MultiSelect", pvValue)
|
||||
End Function ' setMultiSelect
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setOnAction(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOnAction")
|
||||
setOnAction = PropertiesSet._setProperty(pvObject, "OnAction", pvValue)
|
||||
End Function ' setOnAction
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setOptionValue(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOptionValue")
|
||||
setOptionValue = PropertiesSet._setProperty(pvObject, "OptionValue", pvValue)
|
||||
End Function ' setOptionValue
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setOrderBy(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderBy")
|
||||
setOrderBy = PropertiesSet._setProperty(pvObject, "OrderBy", pvValue)
|
||||
End Function ' setOrderBy
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setOrderByOn(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setOrderByOn")
|
||||
setOrderByOn = PropertiesSet._setProperty(pvObject, "OrderByOn", pvValue)
|
||||
End Function ' setOrderByOn
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setPage(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setPage")
|
||||
setPage = PropertiesSet._setProperty(pvObject, "Page", pvValue)
|
||||
End Function ' setPage V0.9.1
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(Optional pvItem As Variant, ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return True if property setting OK
|
||||
Utils._SetCalledSub("setProperty")
|
||||
If IsMissing(pvItem) Or IsMissing(psProperty) Or IsMissing(pvValue) Or IsEmpty(pvItem) Then Call _TraceArguments()
|
||||
If IsMissing(pvIndex) Then
|
||||
setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue)
|
||||
Else
|
||||
setProperty = PropertiesSet._setProperty(pvItem, psProperty, pvValue, pvIndex)
|
||||
End If
|
||||
Utils._ResetCalledSub("setProperty")
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setRecordSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRecordSource")
|
||||
setRecordSource = PropertiesSet._setProperty(pvObject, "RecordSource", pvValue)
|
||||
End Function ' setRecordSource
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setRequired(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRequired")
|
||||
setRequired = PropertiesSet._setProperty(pvObject, "Required", pvValue)
|
||||
End Function ' setRequired
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setRowSource(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSource")
|
||||
setRowSource = PropertiesSet._setProperty(pvObject, "RowSource", pvValue)
|
||||
End Function ' setRowSource
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setRowSourceType(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setRowSourceType")
|
||||
setRowSourceType = PropertiesSet._setProperty(pvObject, "RowSourceType", pvValue)
|
||||
End Function ' setRowSourceType
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setSelected(Optional pvObject As Variant, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Then Call _TraceArguments("setSelected")
|
||||
If IsEmpty(pvObject) Then Call _TraceArguments("setSelected")
|
||||
If IsMissing(pvIndex) Then
|
||||
setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue)
|
||||
Else
|
||||
setSelected = PropertiesSet._setProperty(pvObject, "Selected", pvValue, pvIndex)
|
||||
End If
|
||||
End Function ' setSelected
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setSelLength(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelLength")
|
||||
setSelLength = PropertiesSet._setProperty(pvObject, "SelLength", pvValue)
|
||||
End Function ' setSelLength
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setSelStart(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelStart")
|
||||
setSelStart = PropertiesSet._setProperty(pvObject, "SelStart", pvValue)
|
||||
End Function ' setSelStart
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setSelText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelText")
|
||||
setSelText = PropertiesSet._setProperty(pvObject, "SelText", pvValue)
|
||||
End Function ' setSelText
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setSpecialEffect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSpecialEffect")
|
||||
setSpecialEffect = PropertiesSet._setProperty(pvObject, "SpecialEffect", pvValue)
|
||||
End Function ' setSpecialEffect
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setTabIndex(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabIndex")
|
||||
setTabIndex = PropertiesSet._setProperty(pvObject, "TabIndex", pvValue)
|
||||
End Function ' setTabIndex
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setTabStop(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTabStop")
|
||||
setTabStop = PropertiesSet._setProperty(pvObject, "TabStop", pvValue)
|
||||
End Function ' setTabStop
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setTag(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTag")
|
||||
setTag = PropertiesSet._setProperty(pvObject, "Tag", pvValue)
|
||||
End Function ' setTag
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setTextAlign(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTextAlign")
|
||||
setTextAlign = PropertiesSet._setProperty(pvObject, "TextAlign", pvValue)
|
||||
End Function ' setTextAlign
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setTooltipText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTooltipText")
|
||||
setTooltipText = PropertiesSet._setProperty(pvObject, "TooltipText", pvValue)
|
||||
End Function ' setTooltipText
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setTripleState(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setTripleState")
|
||||
setTripleState = PropertiesSet._setProperty(pvObject, "TripleState", pvValue)
|
||||
End Function ' setTripleState
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setVisible(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms and controls
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setVisible")
|
||||
setVisible = PropertiesSet._setProperty(pvObject, "Visible", pvValue)
|
||||
End Function ' setVisible
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setWidth(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Only for open forms
|
||||
If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setWidth")
|
||||
setWidth = PropertiesSet._setProperty(pvObject, "Width", pvValue)
|
||||
End Function ' setWidth
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private Function _CheckProperty(pvObject As Object, ByVal psProperty As String) As Boolean
|
||||
' Return False if psProperty not within the PropertyValues set of pvItem
|
||||
|
||||
Dim i As Integer, oPropertyValues As Variant, oProperty As Variant
|
||||
oPropertyValues = pvObject.PropertyValues
|
||||
|
||||
For i = LBound(oPropertyValues) To UBound(oPropertyValues)
|
||||
oProperty = oPropertyValues(i)
|
||||
If UCase(oProperty.Name) = UCase(psProperty) Then
|
||||
_CheckProperty = True
|
||||
Exit Function
|
||||
End If
|
||||
Next i
|
||||
|
||||
_CheckProperty = False
|
||||
Exit Function
|
||||
|
||||
End Function ' CheckProperty V0.7.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _setProperty(pvItem As Variant, ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Utils._SetCalledSub("set" & psProperty)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
'pvItem must be an object and have the requested property
|
||||
If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function
|
||||
'Check Index argument
|
||||
If Not IsMissing(pvIndex) Then
|
||||
If Not Utils._CheckArgument(pvIndex, 4, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
End If
|
||||
'Execute
|
||||
Dim iArgNr As Integer, lFormat As Long
|
||||
Dim i As Integer, iCount As Integer, iSelectedItems() As Integer, bListboxBound As Boolean
|
||||
Dim odbDatabase As Object, vNames As Variant, bFound As Boolean, sName As String, oModel As Object
|
||||
Dim ocButton As Variant, iRadioIndex As Integer
|
||||
_setProperty = True
|
||||
If _A2B_.CalledSub = "setProperty" Then iArgNr = 3 Else iArgNr = 2
|
||||
If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error_Control
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("AbsolutePosition")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function
|
||||
pvItem.AbsolutePosition = pvValue
|
||||
Case UCase("AllowAdditions")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.AllowAdditions = pvValue
|
||||
Case UCase("AllowDeletions")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.AllowDeletions = pvValue
|
||||
Case UCase("AllowEdits")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.AllowEdits = pvValue
|
||||
Case UCase("BackColor")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.BackColor = pvValue
|
||||
Case UCase("Bookmark")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJRECORDSET)) Then Goto Exit_Function
|
||||
pvItem.Bookmark = pvValue
|
||||
Case UCase("BorderColor")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.BorderColor = pvValue
|
||||
Case UCase("BorderStyle")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.BorderColor = pvValue
|
||||
Case UCase("Cancel")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.Cancel = pvValue
|
||||
Case UCase("Caption")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function
|
||||
pvItem.Caption = pvValue
|
||||
Case UCase("ControlTipText")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.ControlTipText = pvValue
|
||||
Case UCase("CurrentRecord")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.CurrentRecord = pvValue
|
||||
Case UCase("Default")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.Default = pvValue
|
||||
Case UCase("DefaultValue")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function
|
||||
pvItem.DefaultValue = pvValue
|
||||
Case UCase("Description")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function
|
||||
pvItem.DefaultValue = pvValue
|
||||
Case UCase("Enabled")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.Enabled = pvValue
|
||||
Case UCase("Filter")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM, OBJRECORDSET)) Then Goto Exit_Function
|
||||
pvItem.Filter = pvValue
|
||||
Case UCase("FilterOn")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.FilterOn = pvValue
|
||||
Case UCase("FontBold")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.FontBold = pvValue
|
||||
Case UCase("FontItalic")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.FontItalic = pvValue
|
||||
Case UCase("FontName")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.FontName = pvValue
|
||||
Case UCase("FontSize")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.FontSize = pvValue
|
||||
Case UCase("FontUnderline")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.FontUnderline = pvValue
|
||||
Case UCase("FontWeight")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.FontWeight = pvValue
|
||||
Case UCase("ForeColor")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.ForeColor = pvValue
|
||||
Case UCase("Height")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
|
||||
pvItem.Height = pvValue
|
||||
Case UCase("ListIndex")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.ListIndex = pvValue
|
||||
Case UCase("Locked")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.Locked = pvValue
|
||||
Case UCase("MultiSelect")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.MultiSelect = pvValue
|
||||
Case UCase("OnAction")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
|
||||
pvItem.OnAction = pvValue
|
||||
Case UCase("OptionValue")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.OptionValue = pvValue
|
||||
Case UCase("OrderBy")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.OrderBy = pvValue
|
||||
Case UCase("OrderByOn")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.OrderByOn = pvValue
|
||||
Case UCase("Page")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function
|
||||
pvItem.Page = pvValue
|
||||
Case UCase("RecordSource")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
|
||||
pvItem.RecordSource = pvValue
|
||||
Case UCase("Required")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.Required = pvValue
|
||||
Case UCase("RowSource")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.RowSource = pvValue
|
||||
Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.RowSourceType = pvValue
|
||||
Case UCase("Selected")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
If IsMissing(pvIndex) Then pvItem.Selected = pvValue Else pvItem.SelectedI(pvValue, pvIndex)
|
||||
Case UCase("SelLength")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.SelLength = pvValue
|
||||
Case UCase("SelStart")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.SelStart = pvValue
|
||||
Case UCase("SelText")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.SelText = pvValue
|
||||
Case UCase("SpecialEffect")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.SpecialEffect = pvValue
|
||||
Case UCase("TabIndex")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.TabIndex = pvValue
|
||||
Case UCase("TabStop")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.TabStop = pvValue
|
||||
Case UCase("Tag")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.Tag = pvValue
|
||||
Case UCase("TextAlign")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.TextAlign = pvValue
|
||||
Case UCase("TooltipText")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCOMMANDBARCONTROL) Then Goto Exit_Function
|
||||
pvItem.TooltipText = pvValue
|
||||
Case UCase("TripleState")
|
||||
If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function
|
||||
pvItem.TripleState = pvValue
|
||||
Case UCase("Value")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function
|
||||
pvItem.Value = pvValue
|
||||
Case UCase("Visible")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL)) Then Goto Exit_Function
|
||||
pvItem.Visible = pvValue
|
||||
Case UCase("Width")
|
||||
If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
|
||||
pvItem.Width = pvValue
|
||||
Case Else
|
||||
Goto Trace_Error_Control
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error_Form:
|
||||
TraceError(TRACEFATAL, ERRFORMNOTFOUND, Utils._CalledSub(), 0, 1, pvItem._Name)
|
||||
_setProperty = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Control:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_setProperty = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_setProperty = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Index:
|
||||
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_setProperty = Nothing
|
||||
Goto Exit_Function
|
||||
Trace_Error_Array:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr)
|
||||
_setProperty = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "_setProperty", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' _setProperty V0.9.1
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,152 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Property" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be PROPERTY
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _Value As Variant
|
||||
Private _ParentDatabase As Object
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJPROPERTY
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
_Value = Null
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
Public Function pName() As String ' For compatibility with < V0.9.0
|
||||
pName = _PropertyGet("Name")
|
||||
End Function ' pName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Value() As Variant
|
||||
Value = _PropertyGet("Value")
|
||||
End Property ' Value (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("Property.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("Property.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
_PropertiesList = Array("Name", "ObjectType", "Value")
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("Property.get" & psProperty)
|
||||
_PropertyGet = Nothing
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Value")
|
||||
_PropertyGet = _Value
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("Property.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "Property._PropertyGet", Erl)
|
||||
_PropertyGet = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,613 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Python" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub DebugPrint(ParamArray pvArgs() As Variant)
|
||||
|
||||
'Print arguments unconditionally in console
|
||||
'Arguments are separated by a TAB (simulated by spaces)
|
||||
'Some pvArgs might be missing: a TAB is still generated
|
||||
|
||||
Dim vVarTypes() As Variant, i As Integer
|
||||
Const cstTab = 5
|
||||
On Local Error Goto Exit_Sub ' Never interrupt processing
|
||||
Utils._SetCalledSub("DebugPrint")
|
||||
vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, vbArray + vbByte))
|
||||
|
||||
If UBound(pvArgs) >= 0 Then
|
||||
For i = 0 To UBound(pvArgs)
|
||||
If Not Utils._CheckArgument(pvArgs(i), i + 1, vVarTypes(), , False) Then pvArgs(i) = "[TYPE?]"
|
||||
Next i
|
||||
End If
|
||||
|
||||
Dim sOutput As String, sArg As String
|
||||
sOutput = ""
|
||||
For i = 0 To UBound(pvArgs)
|
||||
sArg = Replace(Utils._CStr(pvArgs(i), _A2B_.DebugPrintShort), "\;", ";")
|
||||
' Add argument to output
|
||||
If i = 0 Then
|
||||
sOutput = sArg
|
||||
Else
|
||||
sOutput = sOutput & Space(cstTab - (Len(sOutput) Mod cstTab)) & sArg
|
||||
End If
|
||||
Next i
|
||||
|
||||
TraceLog(TRACEANY, sOutput, False)
|
||||
|
||||
Exit_Sub:
|
||||
Utils._ResetCalledSub("DebugPrint")
|
||||
Exit Sub
|
||||
End Sub ' DebugPrint V0.9.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PYTHON WRAPPERS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PythonEventsWrapper(Optional poEvent As Variant) As Variant
|
||||
' Python wrapper when Application.Events() method is invoked
|
||||
' The ParamArray mechanism empties UNO objects when they are member of the arguments list
|
||||
' As a workaround, the Application.Events function is executed directly
|
||||
|
||||
If _ErrorHandler() Then On Local Error GoTo Exit_Function ' Do never interrupt
|
||||
PythonEventsWrapper = Null
|
||||
|
||||
Dim vReturn As Variant, vArray As Variant
|
||||
Const cstObject = 1
|
||||
|
||||
vReturn = Application.Events(poEvent)
|
||||
vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type)
|
||||
|
||||
PythonEventsWrapper = vArray
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PythonEventsWrapper V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PythonWrapper(ByVal pvCallType As Variant _
|
||||
, ByVal pvObject As Variant _
|
||||
, ByVal pvScript As Variant _
|
||||
, ParamArray pvArgs() As Variant _
|
||||
) As Variant
|
||||
' Called from Python to apply
|
||||
' - on object with entry pvObject in PythonCache
|
||||
' Conventionally: -1 = Application
|
||||
' -2 = DoCmd
|
||||
' - a script pvScript which type is described by pvCallType
|
||||
' - with arguments pvArgs(0)... (max. 8 for object methods)
|
||||
' The value returned by the method/property is encapsulated in an array
|
||||
' [0] => 0 = scalar or array returned by the method
|
||||
' => 1 = basic object returned by the method
|
||||
' => 2 = a null value
|
||||
' [1] => the object reference or the returned value (complemented with arguments passed by reference, if any) or Null
|
||||
' [2] => the object type or Null
|
||||
' [3] => the object name, if any
|
||||
' or, when pvCallType == vbUNO, as the UNO object returned by the property
|
||||
|
||||
Dim vReturn As Variant, vArray As Variant
|
||||
Dim vObject As Variant, sScript As String, sModule As String
|
||||
Dim i As Integer, iNbArgs As Integer, vArg As Variant, vArgs() As Variant
|
||||
|
||||
Const cstApplication = -1, cstDoCmd = -2
|
||||
Const cstScalar = 0, cstObject = 1, cstNull = 2, cstUNO = 3
|
||||
|
||||
'Conventional special values
|
||||
Const cstNoArgs = "+++NOARGS+++", cstSymEmpty = "+++EMPTY+++", cstSymNull = "+++NULL+++", cstSymMissing = "+++MISSING+++"
|
||||
|
||||
'https://support.office.com/en-us/article/CallByName-fonction-49ce9475-c315-4f13-8d35-e98cfe98729a
|
||||
'Determines the pvCallType
|
||||
Const vbGet = 2, vbLet = 4, vbMethod = 1, vbSet = 8, vbUNO = 16
|
||||
|
||||
If _ErrorHandler() Then On Local Error GoTo Error_Function
|
||||
PythonWrapper = Null
|
||||
|
||||
'Reinterpret arguments one by one into vArgs, examine iso-dates and conventional NoArgs/Empty/Null values
|
||||
iNbArgs = -1
|
||||
vArgs = Array()
|
||||
If UBound(pvArgs) >= 0 Then
|
||||
For i = 0 To UBound(pvArgs)
|
||||
vArg = pvArgs(i)
|
||||
If i = 0 And VarType(vArg) = vbString Then
|
||||
If vArg = cstNoArgs Then Exit For
|
||||
End If
|
||||
If VarType(vArg) = vbString Then
|
||||
If vArg = cstSymEmpty Then
|
||||
vArg = Empty
|
||||
ElseIf vArg = cstSymNull Then
|
||||
vArg = Null
|
||||
ElseIf vArg = cstSymMissing Then
|
||||
Exit For ' Next arguments must be missing also
|
||||
Else
|
||||
vArg = _CDate(vArg)
|
||||
End If
|
||||
End If
|
||||
iNbArgs = iNbArgs + 1
|
||||
ReDim Preserve vArgs(iNbArgs)
|
||||
vArgs(iNbArgs) = vArg
|
||||
Next i
|
||||
End If
|
||||
|
||||
'Check pvObject
|
||||
Select Case pvObject ' Always numeric
|
||||
Case cstApplication
|
||||
sModule = "Application"
|
||||
Select Case pvScript
|
||||
Case "AllDialogs" : If iNbArgs < 0 Then vReturn = Application.AllDialogs() Else vReturn = Application.AllDialogs(vArgs(0))
|
||||
Case "AllForms" : If iNbArgs < 0 Then vReturn = Application.AllForms() Else vReturn = Application.AllForms(vArgs(0))
|
||||
Case "AllModules" : If iNbArgs < 0 Then vReturn = Application.AllModules() Else vReturn = Application.AllModules(vArgs(0))
|
||||
Case "CloseConnection"
|
||||
vReturn = Application.CloseConnection()
|
||||
Case "CommandBars" : If iNbArgs < 0 Then vReturn = Application.CommandBars() Else vReturn = Application.CommandBars(vArgs(0))
|
||||
Case "CurrentDb" : vReturn = Application.CurrentDb()
|
||||
Case "CurrentUser" : vReturn = Application.CurrentUser()
|
||||
Case "DAvg" : vReturn = Application.DAvg(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DCount" : vReturn = Application.DCount(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DLookup" : vReturn = Application.DLookup(vArgs(0), vArgs(1), vArgs(2), vArgs(3))
|
||||
Case "DMax" : vReturn = Application.DMax(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DMin" : vReturn = Application.DMin(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DStDev" : vReturn = Application.DStDev(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DStDevP" : vReturn = Application.DStDevP(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DSum" : vReturn = Application.DSum(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DVar" : vReturn = Application.DVar(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "DVarP" : vReturn = Application.DVarP(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "Forms" : If iNbArgs < 0 Then vReturn = Application.Forms() Else vReturn = Application.Forms(vArgs(0))
|
||||
Case "getObject" : vReturn = Application.getObject(vArgs(0))
|
||||
Case "getValue" : vReturn = Application.getValue(vArgs(0))
|
||||
Case "HtmlEncode" : vReturn = Application.HtmlEncode(vArgs(0), vArgs(1))
|
||||
Case "OpenDatabase" : vReturn = Application.OpenDatabase(vArgs(0), vArgs(1), vArgs(2), vArgs(3))
|
||||
Case "ProductCode" : vReturn = Application.ProductCode()
|
||||
Case "setValue" : vReturn = Application.setValue(vArgs(0), vArgs(1))
|
||||
Case "SysCmd" : vReturn = Application.SysCmd(vArgs(0), vArgs(1), vARgs(2))
|
||||
Case "TempVars" : If iNbArgs < 0 Then vReturn = Application.TempVars() Else vReturn = Application.TempVars(vArgs(0))
|
||||
Case "Version" : vReturn = Application.Version()
|
||||
Case Else
|
||||
GoTo Error_Proc
|
||||
End Select
|
||||
Case cstDoCmd
|
||||
sModule = "DoCmd"
|
||||
Select Case pvScript
|
||||
Case "ApplyFilter" : vReturn = DoCmd.ApplyFilter(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "Close" : vReturn = DoCmd.mClose(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "CopyObject" : vReturn = DoCmd.CopyObject(vArgs(0), vArgs(1), vArgs(2), vArgs(3))
|
||||
Case "FindNext" : vReturn = DoCmd.FindNext()
|
||||
Case "FindRecord" : vReturn = DoCmd.FindRecord(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6))
|
||||
Case "GetHiddenAttribute"
|
||||
vReturn = DoCmd.GetHiddenAttribute(vArgs(0), vArgs(1))
|
||||
Case "GoToControl" : vReturn = DoCmd.GoToControl(vArgs(0))
|
||||
Case "GoToRecord" : vReturn = DoCmd.GoToRecord(vArgs(0), vArgs(1), vArgs(2), vArgs(3))
|
||||
Case "Maximize" : vReturn = DoCmd.Maximize()
|
||||
Case "Minimize" : vReturn = DoCmd.Minimize()
|
||||
Case "MoveSize" : vReturn = DoCmd.MoveSize(vArgs(0), vArgs(1), vArgs(2), vArgs(3))
|
||||
Case "OpenForm" : vReturn = DoCmd.OpenForm(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6))
|
||||
Case "OpenQuery" : vReturn = DoCmd.OpenQuery(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "OpenReport" : vReturn = DoCmd.OpenReport(vArgs(0), vArgs(1))
|
||||
Case "OpenSQL" : vReturn = DoCmd.OpenSQL(vArgs(0), vArgs(1))
|
||||
Case "OpenTable" : vReturn = DoCmd.OpenTable(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "OutputTo" : vReturn = DoCmd.OutputTo(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7))
|
||||
Case "Quit" : _A2B_.CalledSub = "Quit" : GoTo Error_Action
|
||||
Case "RunApp" : vReturn = DoCmd.RunApp(vArgs(0))
|
||||
Case "RunCommand" : vReturn = DoCmd.RunCommand(vArgs(0))
|
||||
Case "RunSQL" : vReturn = DoCmd.RunSQL(vArgs(0), vArgs(1))
|
||||
Case "SelectObject" : vReturn = DoCmd.SelectObject(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "SendObject" : vReturn = DoCmd.SendObject(vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7), vArgs(8), vArgs(9))
|
||||
Case "SetHiddenAttribute"
|
||||
vReturn = DoCmd.SetHiddenAttribute(vArgs(0), vArgs(1), vArgs(2))
|
||||
Case "SetOrderBy" : vReturn = DoCmd.SetOrderBy(vArgs(0), vArgs(1))
|
||||
Case "ShowAllRecords"
|
||||
vReturn = DoCmd.ShowAllRecords()
|
||||
Case Else
|
||||
GoTo Error_Proc
|
||||
End Select
|
||||
Case Else
|
||||
' Locate targeted object
|
||||
If pvObject > UBound(_A2B_.PythonCache) Or pvObject < 0 Then GoTo Error_Object
|
||||
Set vObject = _A2B_.PythonCache(pvObject)
|
||||
If IsNull(vObject) Then
|
||||
If pvScript = "Dispose" Then GoTo Exit_Function Else GoTo Error_Object
|
||||
End If
|
||||
' Preprocessing
|
||||
sScript = pvScript
|
||||
sModule = vObject._Type
|
||||
Select Case sScript
|
||||
Case "Add"
|
||||
If vObject._Type = "COLLECTION" And vObject._CollType = COLLTABLEDEFS Then vArgs = Array(_A2B_.PythonCache(vArgs(0)))
|
||||
Case "Close"
|
||||
sSCript = "mClose"
|
||||
Case "Type"
|
||||
sScript = "pType"
|
||||
Case Else
|
||||
End Select
|
||||
' Execute method
|
||||
Select Case UBound(vArgs) ' Dirty but ... CallByName does not support an array of arguments or return values
|
||||
Case -1
|
||||
If pvCallType = vbUNO Then
|
||||
With vObject
|
||||
Select Case sScript ' List all properties that should be called directly (UNO)
|
||||
Case "BoundField" : vReturn = .BoundField
|
||||
Case "Column" : vReturn = .Column
|
||||
Case "Connection" : vReturn = .Connection
|
||||
case "ContainerWindow" : vReturn = .ContainerWindow
|
||||
Case "ControlModel" : vReturn = .ControlModel
|
||||
Case "ControlView" : vReturn = .ControlView
|
||||
Case "DatabaseForm" : vReturn = .DatabaseForm
|
||||
Case "Document" : vReturn = .Document
|
||||
Case "FormsCollection" : vReturn = .FormsCollection
|
||||
Case "LabelControl" : vReturn = .LabelControl
|
||||
Case "MetaData" : vReturn = .MetaData
|
||||
Case "ParentComponent" : vReturn = .ParentComponent
|
||||
Case "Query" : vReturn = .Query
|
||||
Case "RowSet" : vReturn = .RowSet
|
||||
Case "Table" : vReturn = .Table
|
||||
Case "UnoDialog" : vReturn = .UnoDialog
|
||||
Case Else
|
||||
End Select
|
||||
End With
|
||||
ElseIf sScript = "ItemData" Then ' List all properties that should be called directly (arrays not supported by CallByName)
|
||||
vReturn = vObject.ItemData
|
||||
ElseIf sScript = "LinkChildFields" Then
|
||||
vReturn = vObject.LinkChildFields
|
||||
ElseIf sScript = "LinkMasterFields" Then
|
||||
vReturn = vObject.LinkMasterFields
|
||||
ElseIf sScript = "OpenArgs" Then
|
||||
vReturn = vObject.OpenArgs
|
||||
ElseIf sScript = "Selected" Then
|
||||
vReturn = vObject.Selected
|
||||
ElseIf sScript = "Value" Then
|
||||
vReturn = vObject.Value
|
||||
Else
|
||||
vReturn = CallByName(vObject, sScript, pvCallType)
|
||||
End If
|
||||
Case 0
|
||||
Select Case sScript
|
||||
Case "AppendChunk" ' Arg is a vector, not supported by CallByName
|
||||
vReturn = vObject.GetChunk(vArgs(0), vArgs(1))
|
||||
Case "GetRows" ' Returns an array, not supported by CallByName
|
||||
vReturn = vObject.GetRows(vArgs(0), True) ' Force iso dates
|
||||
Case Else
|
||||
vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0))
|
||||
End Select
|
||||
Case 1
|
||||
Select Case sScript
|
||||
Case "GetChunk" ' Returns a vector, not supported by CallByName
|
||||
vReturn = vObject.GetChunk(vArgs(0), vArgs(1))
|
||||
Case Else
|
||||
vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1))
|
||||
End Select
|
||||
Case 2 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2))
|
||||
Case 3 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3))
|
||||
Case 4 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4))
|
||||
Case 5 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5))
|
||||
Case 6 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6))
|
||||
Case 7 : vReturn = CallByName(vObject, sScript, pvCallType, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6), vArgs(7))
|
||||
End Select
|
||||
' Postprocessing
|
||||
Select Case pvScript
|
||||
Case "Close", "Dispose", "Terminate"
|
||||
Set _A2B_.PythonCache(pvObject) = Nothing
|
||||
Case "Move", "MoveFirst", "MoveLast", "MoveNext", "MovePrevious" ' Pass the new BOF, EOF values (binary format)
|
||||
If vObject._Type = "RECORDSET" Then
|
||||
vReturn = (Iif(vObject.BOF, 1, 0) * 2 + Iif(vObject.EOF, 1, 0)) * Iif(vReturn, 1, -1)
|
||||
End If
|
||||
Case "Find" ' Store in array the arguments passed by reference
|
||||
If vObject._Type = "MODULE" And vReturn = True Then
|
||||
vReturn = Array(vReturn, vArgs(1), vArgs(2), vArgs(3), vArgs(4))
|
||||
End If
|
||||
Case "ProcOfLine" ' Store in array the arguments passed by reference
|
||||
vReturn = Array(vReturn, vArgs(1))
|
||||
Case Else
|
||||
End Select
|
||||
End Select
|
||||
|
||||
' Structure the returned array
|
||||
If pvCallType = vbUNO Then
|
||||
vArray = vReturn
|
||||
Else
|
||||
If IsNull(vReturn) Then
|
||||
vArray = Array(cstNull, Null, Null)
|
||||
ElseIf IsObject(vReturn) Then
|
||||
Select Case vReturn._Type
|
||||
Case "COLLECTION", "COMMANDBARCONTROL", "EVENT"
|
||||
vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type)
|
||||
Case Else
|
||||
vArray = Array(cstObject, _A2B_.AddPython(vReturn), vReturn._Type, vReturn.Name)
|
||||
End Select
|
||||
Else
|
||||
If VarType(vReturn) = vbDate Then
|
||||
vArray = Array(cstScalar, _CStr(vReturn), Null)
|
||||
ElseIf VarType(vReturn) = vbBigint Then ' Could happen for big integer database fields
|
||||
vArray = Array(cstScalar, CLng(vReturn), Null)
|
||||
Else
|
||||
vArray = Array(cstScalar, vReturn, Null)
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
|
||||
PythonWrapper = vArray
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "PythonWrapper", Erl)
|
||||
GoTo Exit_Function
|
||||
Error_Object:
|
||||
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, "Python Wrapper (" & pvScript & ")", 0, , Array(_GetLabel("OBJECT"), "#" & pvObject))
|
||||
GoTo Exit_Function
|
||||
Error_Action:
|
||||
TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
|
||||
GoTo Exit_Function
|
||||
Error_Proc:
|
||||
TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, "Python Wrapper", 0, , Array(pvScript, sModule))
|
||||
GoTo Exit_Function
|
||||
End Function ' PythonWrapper V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PYTHON HELPER FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyConvertFromUrl(ByVal pvFile As Variant) As String
|
||||
' Convenient function to have common conversions of filenames from/to url notations both in Python and Basic
|
||||
|
||||
On Local Error GoTo Exit_Function
|
||||
PyConvertFromUrl = ""
|
||||
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
|
||||
|
||||
PyConvertFromUrl = ConvertFromUrl(pvFile)
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyConvertFromUrl V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyConvertToUrl(ByVal pvFile As Variant) As String
|
||||
' Convenient function to have common conversions of filenames from/to url notations both in Python and Basic
|
||||
|
||||
On Local Error GoTo Exit_Function
|
||||
PyConvertToUrl = ""
|
||||
If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
|
||||
|
||||
PyConvertToUrl = ConvertToUrl(pvFile)
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyConvertToUrl V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyCreateUnoService(ByVal pvService As Variant) As Variant
|
||||
' Convenient function to create a UNO service in Python
|
||||
|
||||
On Local Error GoTo Exit_Function
|
||||
Set PyCreateUnoService = Nothing
|
||||
If Not Utils._CheckArgument(pvService, 1, vbString) Then Goto Exit_Function
|
||||
|
||||
Set PyCreateUnoService = CreateUnoService(pvService)
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyCreateUnoService V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyDateAdd(ByVal pvAdd As Variant _
|
||||
, ByVal pvCount As Variant _
|
||||
, ByVal pvDate As Variant _
|
||||
) As Variant
|
||||
' Convenient shortcut to useful and easy-to-use Basic date functions
|
||||
|
||||
Dim vDate As Variant, vNewDate As Variant
|
||||
On Local Error GoTo Exit_Function
|
||||
PyDateAdd = Null
|
||||
|
||||
If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvCount, 2, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvDate, 3, vbString) Then Goto Exit_Function
|
||||
|
||||
vDate = _CDate(pvDate)
|
||||
vNewDate = DateAdd(pvAdd, pvCount, vDate)
|
||||
If VarType(vNewDate) = vbDate Then PyDateAdd = _CStr(vNewDate) Else PyDateAdd = vNewDate
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyDateAdd V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyDateDiff(ByVal pvAdd As Variant _
|
||||
, ByVal pvDate1 As Variant _
|
||||
, ByVal pvDate2 As Variant _
|
||||
, ByVal pvWeekStart As Variant _
|
||||
, ByVal pvYearStart As Variant _
|
||||
) As Variant
|
||||
' Convenient shortcut to useful and easy-to-use Basic date functions
|
||||
|
||||
Dim vDate1 As Variant, vDate2 As Variant
|
||||
On Local Error GoTo Exit_Function
|
||||
PyDateDiff = Null
|
||||
|
||||
If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvDate1, 2, vbString) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvDate2, 3, vbString) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvWeekStart, 4, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvWeekStart, 5, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
|
||||
vDate1 = _CDate(pvDate1)
|
||||
vDate2 = _CDate(pvDate2)
|
||||
PyDateDiff = DateDiff(pvAdd, vDate1, vDate2, pvWeekStart, pvYearStart)
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyDateDiff V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyDatePart(ByVal pvAdd As Variant _
|
||||
, ByVal pvDate As Variant _
|
||||
, ByVal pvWeekStart As Variant _
|
||||
, ByVal pvYearStart As Variant _
|
||||
) As Variant
|
||||
' Convenient shortcut to useful and easy-to-use Basic date functions
|
||||
|
||||
Dim vDate As Variant
|
||||
On Local Error GoTo Exit_Function
|
||||
PyDatePart = Null
|
||||
|
||||
If Not Utils._CheckArgument(pvAdd, 1, vbString) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvDate, 2, vbString) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvWeekStart, 3, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvWeekStart, 4, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
|
||||
vDate = _CDate(pvDate)
|
||||
PyDatePart = DatePart(pvAdd, vDate, pvWeekStart, pvYearStart)
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyDatePart V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyDateValue(ByVal pvDate As Variant) As Variant
|
||||
' Convenient shortcut to useful and easy-to-use Basic date functions
|
||||
|
||||
Dim vDate As Variant
|
||||
On Local Error GoTo Exit_Function
|
||||
PyDateValue = Null
|
||||
If Not Utils._CheckArgument(pvDate, 1, vbString) Then Goto Exit_Function
|
||||
|
||||
vDate = DateValue(pvDate)
|
||||
If VarType(vDate) = vbDate Then PyDateValue = _CStr(vDate) Else PyDateValue = vDate
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyDateValue V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyFormat(ByVal pvValue As Variant, pvFormat As Variant) As String
|
||||
' Convenient function to format numbers or dates
|
||||
|
||||
On Local Error GoTo Exit_Function
|
||||
PyFormat = ""
|
||||
If Not Utils._CheckArgument(pvValue, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
||||
pvValue = _CDate(pvValue)
|
||||
If IsEmpty(pvFormat) Then
|
||||
PyFormat = Str(pvValue)
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvFormat, 2, vbString) Then Goto Exit_Function
|
||||
PyFormat = Format(pvValue, pvFormat)
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyFormat V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyGetGUIType() As Variant
|
||||
|
||||
PyGetGUIType = GetGUIType()
|
||||
|
||||
End Function ' PyGetGUIType V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyGetSystemTicks() As Variant
|
||||
|
||||
PyGetSystemTicks = GetSystemTicks()
|
||||
|
||||
End Function ' PyGetSystemTicks V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyGlobalScope(ByVal pvLib As Variant) As Variant
|
||||
|
||||
Select Case pvLib
|
||||
Case "Basic"
|
||||
PyGlobalScope = GlobalScope.BasicLibraries()
|
||||
Case "Dialog"
|
||||
PyGlobalScope = GlobalScope.DialogLibraries()
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
End Function ' PyGlobalScope V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyInputBox(ByVal pvText As Variant _
|
||||
, ByVal pvTitle As Variant _
|
||||
, ByVal pvDefault As Variant _
|
||||
, ByVal pvXPos As Variant _
|
||||
, ByVal pvYPos As Variant _
|
||||
) As Variant
|
||||
' Convenient function to open input box from Python
|
||||
|
||||
On Local Error GoTo Exit_Function
|
||||
PyInputBox = Null
|
||||
|
||||
If Not Utils._CheckArgument(pvText, 1, vbString) Then Goto Exit_Function
|
||||
If IsEmpty(pvTitle) Then pvTitle = ""
|
||||
If Not Utils._CheckArgument(pvTitle, 2, vbString) Then Goto Exit_Function
|
||||
If IsEmpty(pvDefault) Then pvDefault = ""
|
||||
If Not Utils._CheckArgument(pvDefault, 3, vbString) Then Goto Exit_Function
|
||||
|
||||
If IsEmpty(pvXPos) Or IsEmpty(pvYPos) Then
|
||||
PyInputBox = InputBox(pvText, pvTitle, pvDefault)
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvXPos, 4, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If Not Utils._CheckArgument(pvYPos, 5, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
PyInputBox = InputBox(pvText, pvTitle, pvDefault, pvXPos, pvYPos)
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyInputBox V6.4.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyMsgBox(ByVal pvText As Variant _
|
||||
, ByVal pvType As Variant _
|
||||
, ByVal pvDialogTitle As Variant _
|
||||
) As Variant
|
||||
' Convenient function to open message box from Python
|
||||
|
||||
On Local Error GoTo Exit_Function
|
||||
PyMsgBox = Null
|
||||
|
||||
If Not Utils._CheckArgument(pvText, 1, vbString) Then Goto Exit_Function
|
||||
If IsEmpty(pvType) Then pvType = 0
|
||||
If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If IsEmpty(pvDialogTitle) Then
|
||||
PyMsgBox = MsgBox(pvText, pvType)
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvDialogTitle, 3, vbString) Then Goto Exit_Function
|
||||
PyMsgBox = MsgBox(pvText, pvType, pvDialogTitle)
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' PyMsgBox V6.4.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function PyTimer() As Long
|
||||
' Convenient function to call Timer from Python
|
||||
|
||||
PyTimer = Timer
|
||||
|
||||
End Function ' PyTimer V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _CDate(ByVal pvValue As Variant) As Variant
|
||||
' Return a Date type if iso date, otherwise return input
|
||||
|
||||
Dim vValue As Variant
|
||||
vValue = pvValue
|
||||
If VarType(pvValue) = vbString Then
|
||||
If pvValue <> "" And IsDate(pvValue) Then vValue = CDate(pvValue) ' IsDate("") gives True !?
|
||||
End If
|
||||
_CDate = vValue
|
||||
|
||||
End Function
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,311 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Root_" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- FOR INTERNAL USE ONLY ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private ErrorHandler As Boolean
|
||||
Private MinimalTraceLevel As Integer
|
||||
Private TraceLogs() As Variant
|
||||
Private TraceLogCount As Integer
|
||||
Private TraceLogLast As Integer
|
||||
Private TraceLogMaxEntries As Integer
|
||||
Private LastErrorCode As Integer
|
||||
Private LastErrorLevel As String
|
||||
Private ErrorText As String
|
||||
Private ErrorLongText As String
|
||||
Private CalledSub As String
|
||||
Private DebugPrintShort As Boolean
|
||||
Private Introspection As Object ' com.sun.star.beans.Introspection
|
||||
Private VersionNumber As String ' Actual Access2Base version number
|
||||
Private Locale As String
|
||||
Private ExcludeA2B As Boolean
|
||||
Private TextSearch As Object
|
||||
Private SearchOptions As Variant
|
||||
Private FindRecord As Object
|
||||
Private StatusBar As Object
|
||||
Private Dialogs As Object ' Collection
|
||||
Private TempVars As Object ' Collection
|
||||
Private CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents
|
||||
Private PythonCache() As Variant ' Array of objects created in Python scripts
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
VersionNumber = Access2Base_Version
|
||||
ErrorHandler = True
|
||||
MinimalTraceLevel = 0
|
||||
TraceLogs() = Array()
|
||||
TraceLogCount = 0
|
||||
TraceLogLast = 0
|
||||
TraceLogMaxEntries = 0
|
||||
LastErrorCode = 0
|
||||
LastErrorLevel = ""
|
||||
ErrorText = ""
|
||||
ErrorLongText = ""
|
||||
CalledSub = ""
|
||||
DebugPrintShort = True
|
||||
Locale = L10N._GetLocale()
|
||||
ExcludeA2B = True
|
||||
Set Introspection = CreateUnoService("com.sun.star.beans.Introspection")
|
||||
Set TextSearch = CreateUnoService("com.sun.star.util.TextSearch")
|
||||
SearchOptions = New com.sun.star.util.SearchOptions
|
||||
With SearchOptions
|
||||
.algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
|
||||
.searchFlag = 0
|
||||
.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
|
||||
End With
|
||||
Set FindRecord = Nothing
|
||||
Set StatusBar = Nothing
|
||||
Set Dialogs = New Collection
|
||||
Set TempVars = New Collection
|
||||
CurrentDoc = Array()
|
||||
ReDim CurrentDoc(0 To 0)
|
||||
Set CurrentDoc(0) = Nothing
|
||||
PythonCache = Array()
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function AddPython(ByRef pvObject As Variant) As Long
|
||||
' Store the object as a new entry in PythonCache and return its entry number
|
||||
|
||||
Dim lVars As Long, vObject As Variant
|
||||
|
||||
lVars = UBound(PythonCache) + 1
|
||||
ReDim Preserve PythonCache(0 To lVars)
|
||||
PythonCache(lVars) = pvObject
|
||||
|
||||
AddPython = lVars
|
||||
|
||||
End Function ' AddPython V6.4
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub CloseConnection()
|
||||
' Close all connections established by current document to free memory.
|
||||
' - if Base document => close the one concerned database connection
|
||||
' - if non-Base documents => close the connections of each individual standalone form
|
||||
|
||||
Dim i As Integer, iCurrentDoc As Integer
|
||||
Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant
|
||||
|
||||
If ErrorHandler Then On Local Error Goto Error_Sub
|
||||
|
||||
If Not IsArray(CurrentDoc) Then Goto Exit_Sub
|
||||
If UBound(CurrentDoc) < 0 Then Goto Exit_Sub
|
||||
iCurrentDoc = CurrentDocIndex( , False) ' False prevents error raising if not found
|
||||
If iCurrentDoc < 0 Then GoTo Exit_Sub ' If not found ignore
|
||||
|
||||
vDocContainer = CurrentDocument(iCurrentDoc)
|
||||
With vDocContainer
|
||||
If Not .Active Then GoTo Exit_Sub ' e.g. if multiple calls to CloseConnection()
|
||||
For i = 0 To UBound(.DbContainers)
|
||||
If Not IsNull(.DbContainers(i).Database) Then
|
||||
.DbContainers(i).Database.Dispose()
|
||||
Set .DbContainers(i).Database = Nothing
|
||||
End If
|
||||
TraceLog(TRACEANY, UCase(CalledSub) & " " & .URL & Iif(i = 0, "", " Form=" & .DbContainers(i).FormName), False)
|
||||
Set .DbContainers(i) = Nothing
|
||||
Next i
|
||||
.DbContainers = Array()
|
||||
.URL = ""
|
||||
.DbConnect = 0
|
||||
.Active = False
|
||||
Set .Document = Nothing
|
||||
End With
|
||||
CurrentDoc(iCurrentDoc) = vDocContainer
|
||||
|
||||
Exit_Sub:
|
||||
Exit Sub
|
||||
Error_Sub:
|
||||
TraceError(TRACEABORT, Err, CalledSub, Erl, False) ' No error message addressed to the user, only stored in console
|
||||
GoTo Exit_Sub
|
||||
End Sub ' CloseConnection
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function CurrentDb() As Object
|
||||
' Returns _A2B_.CurrentDocument().Database as an object to allow access to its properties
|
||||
|
||||
Dim iCurrentDoc As Integer
|
||||
|
||||
Set CurrentDb = Nothing
|
||||
|
||||
If Not IsArray(CurrentDoc) Then Goto Exit_Function
|
||||
If UBound(CurrentDoc) < 0 Then Goto Exit_Function
|
||||
iCurrentDoc = CurrentDocIndex(, False) ' False = no abort
|
||||
If iCurrentDoc >= 0 Then
|
||||
If UBound(CurrentDoc(iCurrentDoc).DbContainers) >= 0 Then Set CurrentDb = CurrentDoc(iCurrentDoc).DbContainers(0).Database
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
End Function ' CurrentDb
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function CurrentDocIndex(Optional pvURL As Variant, Optional pbAbort As Variant) As Integer
|
||||
' Returns the entry in CurrentDoc(...) referring to the current document
|
||||
|
||||
Dim i As Integer, bFound As Boolean, sURL As String
|
||||
Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument"
|
||||
|
||||
bFound = False
|
||||
CurrentDocIndex = -1
|
||||
|
||||
If Not IsArray(CurrentDoc) Then Goto Trace_Error
|
||||
If UBound(CurrentDoc) < 0 Then Goto Trace_Error
|
||||
For i = 1 To UBound(CurrentDoc) ' [0] reserved to database .odb document
|
||||
If IsMissing(pvURL) Then ' Not on 1 single line ?!?
|
||||
If Utils._hasUNOProperty(ThisComponent, "URL") Then
|
||||
sURL = ThisComponent.URL
|
||||
Else
|
||||
Exit For ' f.i. ThisComponent = Basic IDE ...
|
||||
End If
|
||||
Else
|
||||
sURL = pvURL ' To support the SelectObject action
|
||||
End If
|
||||
If CurrentDoc(i).Active And CurrentDoc(i).URL = sURL Then
|
||||
CurrentDocIndex = i
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
|
||||
If Not bFound Then
|
||||
If IsNull(CurrentDoc(0)) Then GoTo Trace_Error
|
||||
With CurrentDoc(0)
|
||||
If Not .Active Then GoTo Trace_Error
|
||||
If IsNull(.Document) Then GoTo Trace_Error
|
||||
End With
|
||||
CurrentDocIndex = 0
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
If IsMissing(pbAbort) Then pbAbort = True
|
||||
If pbAbort Then TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Else CurrentDocIndex = -1
|
||||
Goto Exit_Function
|
||||
End Function ' CurrentDocIndex
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function CurrentDocument(ByVal Optional piDocIndex As Integer) As Variant
|
||||
' Returns the CurrentDoc(...) referring to the current document or to the argument
|
||||
|
||||
Dim iDocIndex As Integer
|
||||
If IsMissing(piDocIndex) Then iDocIndex = CurrentDocIndex(, False) Else iDocIndex = piDocIndex
|
||||
If iDocIndex >= 0 And iDocIndex <= UBound(CurrentDoc) Then Set CurrentDocument = CurrentDoc(iDocIndex) Else Set CurrentDocument = Nothing
|
||||
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dump()
|
||||
' For debugging purposes
|
||||
Dim i As Integer, j As Integer, vCurrentDoc As Variant
|
||||
On Local Error Resume Next
|
||||
|
||||
DebugPrint "Version", VersionNumber
|
||||
DebugPrint "TraceLevel", MinimalTraceLevel
|
||||
DebugPrint "TraceCount", TraceLogCount
|
||||
DebugPrint "CalledSub", CalledSub
|
||||
If IsArray(CurrentDoc) Then
|
||||
For i = 0 To UBound(CurrentDoc)
|
||||
vCurrentDoc = CurrentDoc(i)
|
||||
If Not IsNull(vCurrentDoc) Then
|
||||
DebugPrint i, "URL", vCurrentDoc.URL
|
||||
For j = 0 To UBound(vCurrentDoc.DbContainers)
|
||||
DebugPrint i, j, "Form", vCurrentDoc.DbContainers(j).FormName
|
||||
DebugPrint i, j, "Database", vCurrentDoc.DbContainers(j).Database.Title
|
||||
Next j
|
||||
End If
|
||||
Next i
|
||||
End If
|
||||
|
||||
End Sub
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasItem(psCollType As String, ByVal psName As String) As Boolean
|
||||
' Return True if psName if in the collection
|
||||
|
||||
Dim oItem As Object
|
||||
On Local Error Goto Error_Function ' Whatever ErrorHandler !
|
||||
|
||||
hasItem = True
|
||||
Select Case psCollType
|
||||
Case COLLALLDIALOGS
|
||||
Set oItem = Dialogs.Item(UCase(psName))
|
||||
Case COLLTEMPVARS
|
||||
Set oItem = TempVars.Item(UCase(psName))
|
||||
Case Else
|
||||
hasItem = False
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Exit Function
|
||||
Error_Function: ' Item by key aborted
|
||||
hasItem = False
|
||||
GoTo Exit_Function
|
||||
End Function ' hasItem
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant
|
||||
REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use)
|
||||
REM With 2 arguments return the corresponding entry in Root
|
||||
|
||||
Dim odbDatabase As Variant
|
||||
If IsMissing(piDocEntry) Then
|
||||
Set odbDatabase = CurrentDb()
|
||||
Else
|
||||
If Not IsArray(CurrentDoc) Then Goto Trace_Error
|
||||
If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error
|
||||
If piDocEntry > UBound(CurrentDoc) Then Goto Trace_Error
|
||||
If piDbEntry > UBound(CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error
|
||||
Set odbDatabase = CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database
|
||||
End If
|
||||
If IsNull(odbDatabase) Then GoTo Trace_Error
|
||||
|
||||
Exit_Function:
|
||||
Set _CurrentDb = odbDatabase
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1)
|
||||
Goto Exit_Function
|
||||
End Function ' _CurrentDb
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,757 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SubForm" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be SUBFORM
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Shortcut As String
|
||||
Private _Name As String
|
||||
Private _MainForm As String
|
||||
Private _DocEntry As Integer
|
||||
Private _DbEntry As Integer
|
||||
Private _OrderBy As String
|
||||
Public ParentComponent As Object ' com.sun.star.text.TextDocument
|
||||
Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJSUBFORM
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Shortcut = ""
|
||||
_Name = ""
|
||||
_MainForm = ""
|
||||
_DocEntry = -1
|
||||
_DbEntry = -1
|
||||
_OrderBy = ""
|
||||
Set ParentComponent = Nothing
|
||||
Set DatabaseForm = Nothing
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get AllowAdditions() As Variant
|
||||
AllowAdditions = _PropertyGet("AllowAdditions")
|
||||
End Property ' AllowAdditions (get)
|
||||
|
||||
Property Let AllowAdditions(ByVal pvValue As Variant)
|
||||
Call _PropertySet("AllowAdditions", pvValue)
|
||||
End Property ' AllowAdditions (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get AllowDeletions() As Variant
|
||||
AllowDeletions = _PropertyGet("AllowDeletions")
|
||||
End Property ' AllowDeletions (get)
|
||||
|
||||
Property Let AllowDeletions(ByVal pvValue As Variant)
|
||||
Call _PropertySet("AllowDeletions", pvValue)
|
||||
End Property ' AllowDeletions (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get AllowEdits() As Variant
|
||||
AllowEdits = _PropertyGet("AllowEdits")
|
||||
End Property ' AllowEdits (get)
|
||||
|
||||
Property Let AllowEdits(ByVal pvValue As Variant)
|
||||
Call _PropertySet("AllowEdits", pvValue)
|
||||
End Property ' AllowEdits (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get CurrentRecord() As Variant
|
||||
CurrentRecord = _PropertyGet("CurrentRecord")
|
||||
End Property ' CurrentRecord (get)
|
||||
|
||||
Property Let CurrentRecord(ByVal pvValue As Variant)
|
||||
Call _PropertySet("CurrentRecord", pvValue)
|
||||
End Property ' CurrentRecord (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Filter() As Variant
|
||||
Filter = _PropertyGet("Filter")
|
||||
End Property ' Filter (get)
|
||||
|
||||
Property Let Filter(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Filter", pvValue)
|
||||
End Property ' Filter (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get FilterOn() As Variant
|
||||
FilterOn = _PropertyGet("FilterOn")
|
||||
End Property ' FilterOn (get)
|
||||
|
||||
Property Let FilterOn(ByVal pvValue As Variant)
|
||||
Call _PropertySet("FilterOn", pvValue)
|
||||
End Property ' FilterOn (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get LinkChildFields(ByVal Optional pvIndex As Variant) As Variant
|
||||
If IsMissing(pvIndex) Then LinkChildFields = _PropertyGet("LinkChildFields") Else LinkChildFields = _PropertyGet("LinkChildFields", pvIndex)
|
||||
End Property ' LinkChildFields (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get LinkMasterFields(ByVal Optional pvIndex As Variant) As Variant
|
||||
If IsMissing(pvIndex) Then LinkMasterFields = _PropertyGet("LinkMasterFields") Else LinkMasterFields = _PropertyGet("LinkMasterFields", pvIndex)
|
||||
End Property ' LinkMasterFields (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
Public Function pName() As String ' For compatibility with < V0.9.0
|
||||
pName = _PropertyGet("Name")
|
||||
End Function ' pName (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnApproveCursorMove() As Variant
|
||||
OnApproveCursorMove = _PropertyGet("OnApproveCursorMove")
|
||||
End Property ' OnApproveCursorMove (get)
|
||||
|
||||
Property Let OnApproveCursorMove(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnApproveCursorMove", pvValue)
|
||||
End Property ' OnApproveCursorMove (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnApproveParameter() As Variant
|
||||
OnApproveParameter = _PropertyGet("OnApproveParameter")
|
||||
End Property ' OnApproveParameter (get)
|
||||
|
||||
Property Let OnApproveParameter(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnApproveParameter", pvValue)
|
||||
End Property ' OnApproveParameter (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnApproveReset() As Variant
|
||||
OnApproveReset = _PropertyGet("OnApproveReset")
|
||||
End Property ' OnApproveReset (get)
|
||||
|
||||
Property Let OnApproveReset(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnApproveReset", pvValue)
|
||||
End Property ' OnApproveReset (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnApproveRowChange() As Variant
|
||||
OnApproveRowChange = _PropertyGet("OnApproveRowChange")
|
||||
End Property ' OnApproveRowChange (get)
|
||||
|
||||
Property Let OnApproveRowChange(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnApproveRowChange", pvValue)
|
||||
End Property ' OnApproveRowChange (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnApproveSubmit() As Variant
|
||||
OnApproveSubmit = _PropertyGet("OnApproveSubmit")
|
||||
End Property ' OnApproveSubmit (get)
|
||||
|
||||
Property Let OnApproveSubmit(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnApproveSubmit", pvValue)
|
||||
End Property ' OnApproveSubmit (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnConfirmDelete() As Variant
|
||||
OnConfirmDelete = _PropertyGet("OnConfirmDelete")
|
||||
End Property ' OnConfirmDelete (get)
|
||||
|
||||
Property Let OnConfirmDelete(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnConfirmDelete", pvValue)
|
||||
End Property ' OnConfirmDelete (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnCursorMoved() As Variant
|
||||
OnCursorMoved = _PropertyGet("OnCursorMoved")
|
||||
End Property ' OnCursorMoved (get)
|
||||
|
||||
Property Let OnCursorMoved(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnCursorMoved", pvValue)
|
||||
End Property ' OnCursorMoved (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnErrorOccurred() As Variant
|
||||
OnErrorOccurred = _PropertyGet("OnErrorOccurred")
|
||||
End Property ' OnErrorOccurred (get)
|
||||
|
||||
Property Let OnErrorOccurred(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnErrorOccurred", pvValue)
|
||||
End Property ' OnErrorOccurred (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnLoaded() As Variant
|
||||
OnLoaded = _PropertyGet("OnLoaded")
|
||||
End Property ' OnLoaded (get)
|
||||
|
||||
Property Let OnLoaded(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnLoaded", pvValue)
|
||||
End Property ' OnLoaded (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnReloaded() As Variant
|
||||
OnReloaded = _PropertyGet("OnReloaded")
|
||||
End Property ' OnReloaded (get)
|
||||
|
||||
Property Let OnReloaded(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnReloaded", pvValue)
|
||||
End Property ' OnReloaded (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnReloading() As Variant
|
||||
OnReloading = _PropertyGet("OnReloading")
|
||||
End Property ' OnReloading (get)
|
||||
|
||||
Property Let OnReloading(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnReloading", pvValue)
|
||||
End Property ' OnReloading (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnResetted() As Variant
|
||||
OnResetted = _PropertyGet("OnResetted")
|
||||
End Property ' OnResetted (get)
|
||||
|
||||
Property Let OnResetted(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnResetted", pvValue)
|
||||
End Property ' OnResetted (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnRowChanged() As Variant
|
||||
OnRowChanged = _PropertyGet("OnRowChanged")
|
||||
End Property ' OnRowChanged (get)
|
||||
|
||||
Property Let OnRowChanged(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnRowChanged", pvValue)
|
||||
End Property ' OnRowChanged (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnUnloaded() As Variant
|
||||
OnUnloaded = _PropertyGet("OnUnloaded")
|
||||
End Property ' OnUnloaded (get)
|
||||
|
||||
Property Let OnUnloaded(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnUnloaded", pvValue)
|
||||
End Property ' OnUnloaded (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OnUnloading() As Variant
|
||||
OnUnloading = _PropertyGet("OnUnloading")
|
||||
End Property ' OnUnloading (get)
|
||||
|
||||
Property Let OnUnloading(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OnUnloading", pvValue)
|
||||
End Property ' OnUnloading (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant
|
||||
' Return either an error or an object of type OPTIONGROUP based on its name
|
||||
|
||||
Const cstThisSub = "SubForm.OptionGroup"
|
||||
Dim ogGroup As Object
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvGroupName) Then Call _TraceArguments()
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, ParentComponent, DatabaseForm)
|
||||
If Not IsNull(ogGroup) Then
|
||||
ogGroup._DocEntry = _DocEntry
|
||||
ogGroup._DbEntry = _DbEntry
|
||||
End If
|
||||
Set OptionGroup = ogGroup
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' OptionGroup V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OrderBy() As Variant
|
||||
OrderBy = _PropertyGet("OrderBy")
|
||||
End Property ' OrderBy (get) V1.2.0
|
||||
|
||||
Property Let OrderBy(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OrderBy", pvValue)
|
||||
End Property ' OrderBy (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get OrderByOn() As Variant
|
||||
OrderByOn = _PropertyGet("OrderByOn")
|
||||
End Property ' OrderByOn (get) V1.2.0
|
||||
|
||||
Property Let OrderByOn(ByVal pvValue As Variant)
|
||||
Call _PropertySet("OrderByOn", pvValue)
|
||||
End Property ' OrderByOn (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Parent() As Object
|
||||
|
||||
Utils._SetCalledSub("SubForm.getParent")
|
||||
On Error Goto Error_Function
|
||||
|
||||
Set Parent = _Parent
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("SubForm.getParent")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SubForm.getParent", Erl)
|
||||
Set Parent = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' Parent
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Recordset() As Object
|
||||
Recordset = _PropertyGet("Recordset")
|
||||
End Property ' Recordset (get) V0.9.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get RecordSource() As Variant
|
||||
RecordSource = _PropertyGet("RecordSource")
|
||||
End Property ' RecordSource (get)
|
||||
|
||||
Property Let RecordSource(ByVal pvValue As Variant)
|
||||
Call _PropertySet("RecordSource", pvValue)
|
||||
End Property ' RecordSource (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
|
||||
' Return a Control object with name or index = pvIndex
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("SubForm.Controls")
|
||||
|
||||
Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer
|
||||
Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String
|
||||
Dim j As Integer
|
||||
|
||||
Set ocControl = Nothing
|
||||
iControlCount = DatabaseForm.getCount()
|
||||
|
||||
If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object
|
||||
Set oCounter = New Collect
|
||||
Set oCounter._This = oCounter
|
||||
oCounter._CollType = COLLCONTROLS
|
||||
oCounter._Parent = _This
|
||||
oCounter._Count = iControlCount
|
||||
Set Controls = oCounter
|
||||
Goto Exit_Function
|
||||
End If
|
||||
|
||||
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
||||
|
||||
' Start building the ocControl object
|
||||
' Determine exact name
|
||||
Set ocControl = New Control
|
||||
Set ocControl._This = ocControl
|
||||
Set ocControl._Parent = _This
|
||||
ocControl._ParentType = CTLPARENTISSUBFORM
|
||||
sParentShortcut = _Shortcut
|
||||
sControls() = DatabaseForm.getElementNames()
|
||||
|
||||
Select Case VarType(pvIndex)
|
||||
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
|
||||
If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index
|
||||
ocControl._Name = sControls(pvIndex)
|
||||
Case vbString ' Check control name validity (non case sensitive)
|
||||
bFound = False
|
||||
sIndex = UCase(Utils._Trim(pvIndex))
|
||||
For i = 0 To iControlCount - 1
|
||||
If UCase(sControls(i)) = sIndex Then
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound
|
||||
End Select
|
||||
|
||||
With ocControl
|
||||
._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name)
|
||||
Set .ControlModel = DatabaseForm.getByName(._Name)
|
||||
._ImplementationName = .ControlModel.getImplementationName()
|
||||
._FormComponent = ParentComponent
|
||||
If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId
|
||||
If ._ClassId > 0 And ._ClassId <> acHiddenControl Then
|
||||
Set .ControlView = ParentComponent.CurrentController.getControl(.ControlModel)
|
||||
End If
|
||||
|
||||
._Initialize()
|
||||
._DocEntry = _DocEntry
|
||||
._DbEntry = _DbEntry
|
||||
End With
|
||||
Set Controls = ocControl
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("SubForm.Controls")
|
||||
Exit Function
|
||||
Trace_Error_Index:
|
||||
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Trace_NotFound:
|
||||
TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name))
|
||||
Set Controls = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SubForm.Controls", Erl)
|
||||
Set Controls = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' Controls V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("SubForm.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("SubForm.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Refresh() As Boolean
|
||||
' Refresh data with its most recent value in the database in a form or subform
|
||||
Utils._SetCalledSub("SubForm.Refresh")
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Refresh = False
|
||||
|
||||
Dim oSet As Object
|
||||
Set oSet = DatabaseForm.createResultSet()
|
||||
If Not IsNull(oSet) Then
|
||||
oSet.refreshRow()
|
||||
Refresh = True
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set oSet = Nothing
|
||||
Utils._ResetCalledSub("SubForm.Refresh")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Refresh
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Requery() As Boolean
|
||||
' Refresh data displayed in a form, subform, combobox or listbox
|
||||
Utils._SetCalledSub("SubForm.Requery")
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Requery = False
|
||||
|
||||
DatabaseForm.reload()
|
||||
Requery = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("SubForm.Requery")
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SubForm.Requery", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Requery
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Utils._SetCalledSub("SubForm.setProperty")
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub("SubForm.setProperty")
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private Function _GetListener(ByVal psProperty As String) As String
|
||||
' Return the X...Listener corresponding with the property in argument
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("OnApproveCursorMove")
|
||||
_GetListener = "XRowSetApproveListener"
|
||||
Case UCase("OnApproveParameter")
|
||||
_GetListener = "XDatabaseParameterListener"
|
||||
Case UCase("OnApproveReset"), UCase("OnResetted")
|
||||
_GetListener = "XResetListener"
|
||||
Case UCase("OnApproveRowChange")
|
||||
_GetListener = "XRowSetApproveListener"
|
||||
Case UCase("OnApproveSubmit")
|
||||
_GetListener = "XSubmitListener"
|
||||
Case UCase("OnConfirmDelete")
|
||||
_GetListener = "XConfirmDeleteListener"
|
||||
Case UCase("OnCursorMoved"), UCase("OnRowChanged")
|
||||
_GetListener = "XRowSetListener"
|
||||
Case UCase("OnErrorOccurred")
|
||||
_GetListener = "XSQLErrorListener"
|
||||
Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading")
|
||||
_GetListener = "XLoadListener"
|
||||
End Select
|
||||
|
||||
End Function ' _GetListener V1.7.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
_PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "CurrentRecord" _
|
||||
, "Filter", "FilterOn", "LinkChildFields", "LinkMasterFields", "Name" _
|
||||
, "ObjectType", "OnApproveCursorMove", "OnApproveParameter" _
|
||||
, "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _
|
||||
, "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _
|
||||
, "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "OrderBy" _
|
||||
, "OrderByOn", "Parent", "RecordSource" _
|
||||
) ' Recordset removed
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("SubForm.get" & psProperty)
|
||||
Dim iArgNr As Integer
|
||||
If Not IsMissing(pvIndex) Then
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("getProperty") : iArgNr = 3
|
||||
Case UCase("SubForm.getProperty") : iArgNr = 2
|
||||
Case UCase("SubForm.get" & psProperty) : iArgNr = 1
|
||||
End Select
|
||||
If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
End If
|
||||
|
||||
'Execute
|
||||
Dim oDatabase As Object, vBookmark As Variant, oObject As Object
|
||||
_PropertyGet = EMPTY
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("AllowAdditions")
|
||||
_PropertyGet = DatabaseForm.AllowInserts
|
||||
Case UCase("AllowDeletions")
|
||||
_PropertyGet = DatabaseForm.AllowDeletes
|
||||
Case UCase("AllowEdits")
|
||||
_PropertyGet = DatabaseForm.AllowUpdates
|
||||
Case UCase("CurrentRecord")
|
||||
_PropertyGet = DatabaseForm.Row
|
||||
Case UCase("Filter")
|
||||
_PropertyGet = DatabaseForm.Filter
|
||||
Case UCase("FilterOn")
|
||||
_PropertyGet = DatabaseForm.ApplyFilter
|
||||
Case UCase("LinkChildFields")
|
||||
If Utils._hasUNOProperty(DatabaseForm, "DetailFields") Then
|
||||
If IsMissing(pvIndex) Then
|
||||
_PropertyGet = DatabaseForm.DetailFields
|
||||
Else
|
||||
If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.DetailFields) Then Goto trace_Error_Index
|
||||
_PropertyGet = DatabaseForm.DetailFields(pvIndex)
|
||||
End If
|
||||
End If
|
||||
Case UCase("LinkMasterFields")
|
||||
If Utils._hasUNOProperty(DatabaseForm, "MasterFields") Then
|
||||
If IsMissing(pvIndex) Then
|
||||
_PropertyGet = DatabaseForm.MasterFields
|
||||
Else
|
||||
If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.MasterFields) Then Goto trace_Error_Index
|
||||
_PropertyGet = DatabaseForm.MasterFields(pvIndex)
|
||||
End If
|
||||
End If
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _
|
||||
, UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _
|
||||
, UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _
|
||||
, UCase("OnUnloaded"), UCase("OnUnloading")
|
||||
_PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name)
|
||||
Case UCase("OrderBy")
|
||||
_PropertyGet = _OrderBy
|
||||
Case UCase("OrderByOn")
|
||||
If DatabaseForm.Order = "" Then _PropertyGet = False Else _PropertyGet = True
|
||||
Case UCase("Parent") ' Only for indirect access from property object
|
||||
_PropertyGet = Parent
|
||||
Case UCase("Recordset")
|
||||
If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ??
|
||||
Set oObject = New Recordset
|
||||
With DatabaseForm
|
||||
Set oObject._This = oObject
|
||||
oObject._CommandType = .CommandType
|
||||
oObject._Command = .Command
|
||||
oObject._ParentName = _Name
|
||||
oObject._ParentType = _Type
|
||||
Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
|
||||
Set oObject._ParentDatabase = oDatabase
|
||||
Set oObject._ParentDatabase.Connection = .ActiveConnection
|
||||
oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY )
|
||||
oObject._PassThrough = ( .EscapeProcessing = False )
|
||||
oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY )
|
||||
Call oObject._Initialize()
|
||||
End With
|
||||
With oDatabase
|
||||
.RecordsetMax = .RecordsetMax + 1
|
||||
oObject._Name = Format(.RecordsetMax, "0000000")
|
||||
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
|
||||
End With
|
||||
Set _PropertyGet = oObject
|
||||
Case UCase("RecordSource")
|
||||
_PropertyGet = DatabaseForm.Command
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("SubForm.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Trace_Error_Index:
|
||||
TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SubForm._PropertyGet", Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
|
||||
Utils._SetCalledSub("SubForm.set" & psProperty)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
_PropertySet = True
|
||||
|
||||
'Execute
|
||||
Dim iArgNr As Integer
|
||||
|
||||
If _IsLeft(_A2B_.CalledSub, "SubForm.") Then iArgNr = 1 Else iArgNr = 2
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("AllowAdditions")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.AllowInserts = pvValue
|
||||
DatabaseForm.reload()
|
||||
Case UCase("AllowDeletions")
|
||||
If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.AllowDeletes = pvValue
|
||||
DatabaseForm.reload()
|
||||
Case UCase("AllowEdits")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.AllowUpdates = pvValue
|
||||
DatabaseForm.reload()
|
||||
Case UCase("CurrentRecord")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.absolute(pvValue)
|
||||
Case UCase("Filter")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
|
||||
Case UCase("FilterOn")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.ApplyFilter = pvValue
|
||||
DatabaseForm.reload()
|
||||
Case UCase("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _
|
||||
, UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _
|
||||
, UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _
|
||||
, UCase("OnUnloaded"), UCase("OnUnloading")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
If Not Utils._RegisterEventScript(DatabaseForm _
|
||||
, psProperty _
|
||||
, _GetListener(psProperty) _
|
||||
, pvValue, _Name _
|
||||
) Then GoTo Trace_Error
|
||||
Case UCase("OrderBy")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
_OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
|
||||
Case UCase("OrderByOn")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
|
||||
If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = ""
|
||||
DatabaseForm.reload()
|
||||
Case UCase("RecordSource")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue)
|
||||
DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND
|
||||
DatabaseForm.Filter = ""
|
||||
DatabaseForm.reload()
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("SubForm.set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "SubForm._PropertySet", Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,195 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="TempVar" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be TEMPVAR
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String
|
||||
Private _Value As Variant
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = OBJTEMPVAR
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
_Value = Null
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get Value() As Variant
|
||||
Value = _PropertyGet("Value")
|
||||
End Property ' Value (get)
|
||||
|
||||
Property Let Value(ByVal pvValue As Variant)
|
||||
Call _PropertySet("Value", pvValue)
|
||||
End Property ' Value (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Utils._SetCalledSub("TempVar.getProperty")
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub("TempVar.getProperty")
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Utils._SetCalledSub("TempVar.getProperty")
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub("TempVar.getProperty")
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
_PropertiesList = Array("Name", "ObjectType", "Value")
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Utils._SetCalledSub("TempVar.get" & psProperty)
|
||||
_PropertyGet = Nothing
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("Value")
|
||||
_PropertyGet = _Value
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("TempVar.get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertyGet = Nothing
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "TempVar._PropertyGet", Erl)
|
||||
_PropertyGet = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
|
||||
Utils._SetCalledSub("TempVar.set" & psProperty)
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
_PropertySet = True
|
||||
|
||||
'Execute
|
||||
Dim iArgNr As Integer
|
||||
|
||||
If _IsLeft(_A2B_.CalledSub, "TempVar.") Then iArgNr = 1 Else iArgNr = 2
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Value")
|
||||
_Value = pvValue
|
||||
_A2B_.TempVars.Item(UCase(_Name)).Value = pvValue
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub("TempVar.set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, "TempVar._PropertySet", Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,14 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Test" script:language="StarBasic">Option Explicit
|
||||
'Option Compatible
|
||||
|
||||
Sub Main
|
||||
Dim a, b()
|
||||
_ErrorHandler(False)
|
||||
' DebugPrint vbLF
|
||||
' TraceConsole()
|
||||
exit sub
|
||||
End Sub
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,438 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Trace" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Explicit
|
||||
|
||||
Public Const cstLogMaxEntries = 99
|
||||
|
||||
REM Typical Usage
|
||||
REM TraceLog("INFO", "The OK button was pressed")
|
||||
REM
|
||||
REM Typical Usage for error logging
|
||||
REM Sub MySub()
|
||||
REM On Local Error GoTo Error_Sub
|
||||
REM ...
|
||||
REM Exit_Sub:
|
||||
REM Exit Sub
|
||||
REM Error_Sub:
|
||||
REM TraceError("ERROR", Err, "MySub", Erl)
|
||||
REM GoTo Exit_Sub
|
||||
REM End Sub
|
||||
REM
|
||||
REM To display the current logged traces and/or to set parameters
|
||||
REM TraceConsole()
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub TraceConsole()
|
||||
' Display the Trace dialog with current trace log values and parameter choices
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Sub
|
||||
|
||||
Dim sLineBreak As String, oTraceDialog As Object
|
||||
sLineBreak = vbNewLine
|
||||
|
||||
Set oTraceDialog = CreateUnoDialog(Utils._GetDialogLib().dlgTrace)
|
||||
oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE")
|
||||
oTraceDialog.Model.HelpText = _GetLabel("DLGTRACE_HELP")
|
||||
|
||||
Dim oEntries As Object, oTraceLog As Object, oClear As Object, oMinLevel As Object, oNbEntries As Object, oDump As Object
|
||||
Dim oControl As Object
|
||||
Dim i As Integer, sText As String, iOKCancel As Integer
|
||||
|
||||
Set oNbEntries = oTraceDialog.Model.getByName("numNbEntries")
|
||||
oNbEntries.Value = _A2B_.TraceLogCount
|
||||
oNbEntries.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP")
|
||||
|
||||
Set oControl = oTraceDialog.Model.getByName("lblNbEntries")
|
||||
oControl.Label = _GetLabel("DLGTRACE_LBLNBENTRIES_LABEL")
|
||||
oControl.HelpText = _GetLabel("DLGTRACE_LBLNBENTRIES_HELP")
|
||||
|
||||
Set oEntries = oTraceDialog.Model.getByName("numEntries")
|
||||
If _A2B_.TraceLogMaxEntries = 0 Then _A2B_.TraceLogMaxEntries = cstLogMaxEntries
|
||||
oEntries.Value = _A2B_.TraceLogMaxEntries
|
||||
oEntries.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP")
|
||||
|
||||
Set oControl = oTraceDialog.Model.getByName("lblEntries")
|
||||
oControl.Label = _GetLabel("DLGTRACE_LBLENTRIES_LABEL")
|
||||
oControl.HelpText = _GetLabel("DLGTRACE_LBLENTRIES_HELP")
|
||||
|
||||
Set oDump = oTraceDialog.Model.getByName("cmdDump")
|
||||
oDump.Enabled = 0
|
||||
oDump.Label = _GetLabel("DLGTRACE_CMDDUMP_LABEL")
|
||||
oDump.HelpText = _GetLabel("DLGTRACE_CMDDUMP_HELP")
|
||||
|
||||
Set oTraceLog = oTraceDialog.Model.getByName("txtTraceLog")
|
||||
oTraceLog.HelpText = _GetLabel("DLGTRACE_TXTTRACELOG_HELP")
|
||||
If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized
|
||||
oTraceLog.HardLineBreaks = True
|
||||
sText = ""
|
||||
If _A2B_.TraceLogCount > 0 Then
|
||||
If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast
|
||||
Do
|
||||
If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0
|
||||
If Len(_A2B_.TraceLogs(i)) > 11 Then
|
||||
sText = sText & Right(_A2B_.TraceLogs(i), Len(_A2B_.TraceLogs(i)) - 11) & sLineBreak ' Skip date in display
|
||||
End If
|
||||
Loop While i <> _A2B_.TraceLogLast
|
||||
oDump.Enabled = 1 ' Enable DumpToFile only if there is something to dump
|
||||
End If
|
||||
If Len(sText) > 0 Then sText = Left(sText, Len(sText) - Len(sLineBreak)) ' Skip last linefeed
|
||||
oTraceLog.Text = sText
|
||||
Else
|
||||
oTraceLog.Text = _GetLabel("DLGTRACE_TXTTRACELOG_TEXT")
|
||||
End If
|
||||
|
||||
Set oClear = oTraceDialog.Model.getByName("chkClear")
|
||||
oClear.State = 0 ' Unchecked
|
||||
oClear.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP")
|
||||
|
||||
Set oControl = oTraceDialog.Model.getByName("lblClear")
|
||||
oControl.Label = _GetLabel("DLGTRACE_LBLCLEAR_LABEL")
|
||||
oControl.HelpText = _GetLabel("DLGTRACE_LBLCLEAR_HELP")
|
||||
|
||||
Set oMinLevel = oTraceDialog.Model.getByName("cboMinLevel")
|
||||
If _A2B_.MinimalTraceLevel = 0 Then _A2B_.MinimalTraceLevel = _TraceLevel(TRACEERRORS)
|
||||
oMinLevel.Text = _TraceLevel(_A2B_.MinimalTraceLevel)
|
||||
oMinLevel.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP")
|
||||
|
||||
Set oControl = oTraceDialog.Model.getByName("lblMinLevel")
|
||||
oControl.Label = _GetLabel("DLGTRACE_LBLMINLEVEL_LABEL")
|
||||
oControl.HelpText = _GetLabel("DLGTRACE_LBLMINLEVEL_HELP")
|
||||
|
||||
Set oControl = oTraceDialog.Model.getByName("cmdOK")
|
||||
oControl.Label = _GetLabel("DLGTRACE_CMDOK_LABEL")
|
||||
oControl.HelpText = _GetLabel("DLGTRACE_CMDOK_HELP")
|
||||
|
||||
Set oControl = oTraceDialog.Model.getByName("cmdCancel")
|
||||
oControl.Label = _GetLabel("DLGTRACE_CMDCANCEL_LABEL")
|
||||
oControl.HelpText = _GetLabel("DLGTRACE_CMDCANCEL_HELP")
|
||||
|
||||
iOKCancel = oTraceDialog.Execute()
|
||||
|
||||
Select Case iOKCancel
|
||||
Case 1 ' OK
|
||||
If oClear.State = 1 Then
|
||||
_A2B_.TraceLogs() = Array() ' Erase logged traces
|
||||
_A2B_.TraceLogCount = 0
|
||||
End If
|
||||
If oMinLevel.Text <> "" Then _A2B_.MinimalTraceLevel = _TraceLevel(oMinLevel.Text)
|
||||
If oEntries.Value <> 0 And oEntries.Value <> _A2B_.TraceLogMaxEntries Then
|
||||
_A2B_.TraceLogs() = Array()
|
||||
_A2B_.TraceLogMaxEntries = oEntries.Value
|
||||
End If
|
||||
Case 0 ' Cancel
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
Exit_Sub:
|
||||
If Not IsNull(oTraceDialog) Then oTraceDialog.Dispose()
|
||||
Exit Sub
|
||||
Error_Sub:
|
||||
With _A2B_
|
||||
.TraceLogs() = Array()
|
||||
.TraceLogCount = 0
|
||||
.TraceLogLast = 0
|
||||
End With
|
||||
GoTo Exit_Sub
|
||||
End Sub ' TraceConsole V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub TraceError(ByVal psErrorLevel As String _
|
||||
, ByVal piErrorCode As Integer _
|
||||
, ByVal psErrorProc As String _
|
||||
, ByVal piErrorLine As Integer _
|
||||
, ByVal Optional pvMsgBox As Variant _
|
||||
, ByVal Optional pvArgs As Variant _
|
||||
)
|
||||
' Store error code and description in trace rolling buffer
|
||||
' Display error message if errorlevel >= ERROR
|
||||
' Stop program execution if errorlevel = FATAL or ABORT
|
||||
|
||||
On Local Error Resume Next
|
||||
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session
|
||||
|
||||
Dim sErrorText As String, sErrorDesc As String, oDb As Object, bMsgBox As Boolean
|
||||
sErrorDesc = _ErrorMessage(piErrorCode, pvArgs)
|
||||
sErrorText = _GetLabel("ERR#") & CStr(piErrorCode) _
|
||||
& " (" & sErrorDesc & ") " & _GetLabel("ERROCCUR") _
|
||||
& Iif(piErrorLine > 0, " " & _GetLabel("ERRLINE") & " " & CStr(piErrorLine), "") _
|
||||
& Iif(psErrorProc <> "", " " & _GetLabel("ERRIN") & " " & psErrorProc, Iif(_A2B_.CalledSub = "", "", " " & _Getlabel("ERRIN") & " " & _A2B_.CalledSub))
|
||||
With _A2B_
|
||||
.LastErrorCode = piErrorCode
|
||||
.LastErrorLevel = psErrorLevel
|
||||
.ErrorText = sErrorDesc
|
||||
.ErrorLongText = sErrorText
|
||||
.CalledSub = ""
|
||||
End With
|
||||
If VarType(pvMsgBox) = vbError Then
|
||||
bMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT )
|
||||
ElseIf IsMissing(pvMsgBox) Then
|
||||
bMsgBox = ( psErrorLevel = TRACEERRORS Or psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT )
|
||||
Else
|
||||
bMsgBox = pvMsgBox
|
||||
End If
|
||||
TraceLog(psErrorLevel, sErrorText, bMsgBox)
|
||||
|
||||
' Unexpected error detected in user program or in Access2Base
|
||||
If psErrorLevel = TRACEFATAL Or psErrorLevel = TRACEABORT Then
|
||||
If psErrorLevel = TRACEFATAL Then
|
||||
Set oDb = _A2B_.CurrentDb()
|
||||
If Not IsNull(oDb) Then oDb.CloseAllrecordsets()
|
||||
End If
|
||||
Stop
|
||||
End If
|
||||
|
||||
End Sub ' TraceError V0.9.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function TraceErrorCode() As Variant
|
||||
' Return the last encountered error code, level, description in an array
|
||||
' UNPUBLISHED
|
||||
|
||||
Dim vError As Variant
|
||||
|
||||
With _A2B_
|
||||
vError = Array( _
|
||||
.LastErrorCode _
|
||||
, .LastErrorLevel _
|
||||
, .ErrorText _
|
||||
, .ErrorLongText _
|
||||
)
|
||||
End With
|
||||
TraceErrorCode = vError
|
||||
|
||||
End Function ' TraceErrorCode V6.3
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub TraceLevel(ByVal Optional psTraceLevel As String)
|
||||
' Set trace level to argument
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Sub
|
||||
Select Case True
|
||||
Case IsMissing(psTraceLevel) : psTraceLevel = "ERROR"
|
||||
Case psTraceLevel = "" : psTraceLevel = "ERROR"
|
||||
Case Utils._InList(UCase(psTraceLevel), Array( _
|
||||
TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT _
|
||||
))
|
||||
Case Else : Goto Exit_Sub
|
||||
End Select
|
||||
_A2B_.MinimalTraceLevel = _TraceLevel(psTraceLevel)
|
||||
|
||||
Exit_Sub:
|
||||
Exit Sub
|
||||
Error_Sub:
|
||||
With _A2B_
|
||||
.TraceLogs() = Array()
|
||||
.TraceLogCount = 0
|
||||
.TraceLogLast = 0
|
||||
End With
|
||||
GoTo Exit_Sub
|
||||
End Sub ' TraceLevel V0.9.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub TraceLog(ByVal psTraceLevel As String _
|
||||
, ByVal psText As String _
|
||||
, ByVal Optional pbMsgBox As Boolean _
|
||||
)
|
||||
' Store Text in trace log (circular buffer)
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Sub
|
||||
Dim vTraceLogs() As String, sTraceLevel As String
|
||||
|
||||
With _A2B_
|
||||
If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS)
|
||||
If _TraceLevel(psTraceLevel) < .MinimalTraceLevel Then Exit Sub
|
||||
|
||||
If UBound(.TraceLogs) = -1 Then ' Initialize TraceLog
|
||||
If .TraceLogMaxEntries = 0 Then .TraceLogMaxEntries = cstLogMaxEntries
|
||||
|
||||
Redim vTraceLogs(0 To .TraceLogMaxEntries - 1)
|
||||
.TraceLogs = vTraceLogs
|
||||
.TraceLogCount = 0
|
||||
.TraceLogLast = -1
|
||||
If .MinimalTraceLevel = 0 Then .MinimalTraceLevel = _TraceLevel(TRACEERRORS) ' Set default value
|
||||
End If
|
||||
|
||||
.TraceLogLast = .TraceLogLast + 1
|
||||
If .TraceLogLast > UBound(.TraceLogs) Then .TraceLogLast = LBound(.TraceLogs) ' Circular buffer
|
||||
If Len(psTraceLevel) > 7 Then sTraceLevel = Left(psTraceLevel, 7) Else sTraceLevel = psTraceLevel & Spc(8 - Len(psTraceLevel))
|
||||
.TraceLogs(.TraceLogLast) = Format(Now(), "YYYY-MM-DD hh:mm:ss") & " " & sTraceLevel & psText
|
||||
If .TraceLogCount <= UBound(.TraceLogs) Then .TraceLogCount = .TraceLogCount + 1 ' # of active entries
|
||||
End With
|
||||
|
||||
If IsMissing(pbMsgBox) Then pbMsgBox = True
|
||||
Dim iMsgBox As Integer
|
||||
If pbMsgBox Then
|
||||
Select Case psTraceLevel
|
||||
Case TRACEINFO: iMsgBox = vbInformation
|
||||
Case TRACEERRORS, TRACEWARNING: iMsgBox = vbExclamation
|
||||
Case TRACEFATAL, TRACEABORT: iMsgBox = vbCritical
|
||||
Case Else: iMsgBox = vbInformation
|
||||
End Select
|
||||
MsgBox psText, vbOKOnly + iMsgBox, psTraceLevel
|
||||
End If
|
||||
|
||||
Exit_Sub:
|
||||
Exit Sub
|
||||
Error_Sub:
|
||||
With _A2B_
|
||||
.TraceLogs() = Array()
|
||||
.TraceLogCount = 0
|
||||
.TraceLogLast = 0
|
||||
End With
|
||||
GoTo Exit_Sub
|
||||
End Sub ' TraceLog V0.9.5
|
||||
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private Sub _DumpToFile(oEvent As Object)
|
||||
' Execute the Dump To File command from the Trace dialog
|
||||
' Modified from Andrew Pitonyak's Base Macro Programming §10.4
|
||||
|
||||
|
||||
If _ErrorHandler() Then On Local Error GoTo Error_Sub
|
||||
|
||||
Dim sPath as String, iFileNumber As Integer, i As Integer
|
||||
|
||||
sPath = _PromptFilePicker("txt")
|
||||
If sPath <> "" Then ' Save button pressed
|
||||
If UBound(_A2B_.TraceLogs) >= 0 Then ' Array yet initialized
|
||||
iFileNumber = FreeFile()
|
||||
Open sPath For Append Access Write Lock Read As iFileNumber
|
||||
If _A2B_.TraceLogCount > 0 Then
|
||||
If _A2B_.TraceLogCount < _A2B_.TraceLogMaxEntries Then i = -1 Else i = _A2B_.TraceLogLast
|
||||
Do
|
||||
If i < _A2B_.TraceLogMaxEntries - 1 Then i = i + 1 Else i = 0
|
||||
Print #iFileNumber _A2B_.TraceLogs(i)
|
||||
Loop While i <> _A2B_.TraceLogLast
|
||||
End If
|
||||
Close iFileNumber
|
||||
MsgBox _GetLabel("SAVECONSOLEENTRIES"), vbOK + vbInformation, _GetLabel("SAVECONSOLE")
|
||||
End If
|
||||
End If
|
||||
|
||||
Exit_Sub:
|
||||
Exit Sub
|
||||
Error_Sub:
|
||||
TraceError("ERROR", Err, "DumpToFile", Erl)
|
||||
GoTo Exit_Sub
|
||||
End Sub ' DumpToFile V0.8.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _ErrorHandler(Optional ByVal pbCheck As Boolean) As Boolean
|
||||
' Indicate if error handler is activated or not
|
||||
' When argument present set error handler
|
||||
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current LibO/AOO session
|
||||
If Not IsMissing(pbCheck) Then _A2B_.ErrorHandler = pbCheck
|
||||
_ErrorHandler = _A2B_.ErrorHandler
|
||||
Exit Function
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _ErrorMessage(ByVal piErrorNumber As Integer, Optional ByVal pvArgs As Variant) As String
|
||||
' Return error message corresponding to ErrorNumber (standard or not)
|
||||
' and replaces %0, %1, ... , %9 by psArgs(0), psArgs(1), ...
|
||||
|
||||
Dim sErrorMessage As String, i As Integer, sErrLabel
|
||||
_ErrorMessage = ""
|
||||
If piErrorNumber > ERRINIT Then
|
||||
sErrLabel = "ERR" & piErrorNumber
|
||||
sErrorMessage = _Getlabel(sErrLabel)
|
||||
If Not IsMissing(pvArgs) Then
|
||||
If Not IsArray(pvArgs) Then
|
||||
sErrorMessage = Join(Split(sErrorMessage, "%0"), Utils._CStr(pvArgs, False))
|
||||
Else
|
||||
For i = LBound(pvArgs) To UBound(pvArgs)
|
||||
sErrorMessage = Join(Split(sErrorMessage, "%" & i), Utils._CStr(pvArgs(i), False))
|
||||
Next i
|
||||
End If
|
||||
End If
|
||||
Else
|
||||
sErrorMessage = Error(piErrorNumber)
|
||||
' Most (or all?) error messages terminate with a "."
|
||||
If Len(sErrorMessage) > 1 And Right(sErrorMessage, 1) = "." Then sErrorMessage = Left(sErrorMessage, Len(sErrorMessage)-1)
|
||||
End If
|
||||
|
||||
_ErrorMessage = sErrorMessage
|
||||
Exit Function
|
||||
|
||||
End Function ' ErrorMessage V0.8.9
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function _PromptFilePicker(ByVal psSuffix As String) As String
|
||||
' Prompt for output file name
|
||||
' Return "" if Cancel
|
||||
' Modified from Andrew Pitonyak's Base Macro Programming §10.4
|
||||
|
||||
If _ErrorHandler() Then On Local Error GoTo Error_Function
|
||||
|
||||
Dim oFileDialog as Object, oUcb as object, oPath As Object
|
||||
Dim iAccept as Integer, sInitPath as String
|
||||
|
||||
Set oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
|
||||
oFileDialog.Initialize(Array(com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION))
|
||||
Set oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
|
||||
|
||||
oFileDialog.appendFilter("*." & psSuffix, "*." & psSuffix)
|
||||
oFileDialog.appendFilter("*.*", "*.*")
|
||||
oFileDialog.setCurrentFilter("*." & psSuffix)
|
||||
Set oPath = createUnoService("com.sun.star.util.PathSettings")
|
||||
sInitPath = oPath.Work ' Probably My Documents
|
||||
If oUcb.Exists(sInitPath) Then oFileDialog.SetDisplayDirectory(sInitPath)
|
||||
|
||||
iAccept = oFileDialog.Execute()
|
||||
|
||||
_PromptFilePicker = ""
|
||||
If iAccept = 1 Then ' Save button pressed
|
||||
_PromptFilePicker = oFileDialog.Files(0)
|
||||
End If
|
||||
|
||||
Exit_Function:
|
||||
If Not IsEmpty(oFileDialog) And Not IsNull(oFileDialog) Then oFileDialog.Dispose()
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError("ERROR", Err, "PromptFilePicker", Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' PromptFilePicker V0.8.5
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub _TraceArguments(Optional psCall As String)
|
||||
' Process the ERRMISSINGARGUMENTS error
|
||||
' psCall is present if error detected before call to _SetCalledSub
|
||||
|
||||
If Not IsMissing(psCall) Then Utils._SetCalledSub(psCall)
|
||||
TraceError(TRACEFATAL, ERRMISSINGARGUMENTS, Utils._CalledSub(), 0)
|
||||
Exit Sub
|
||||
|
||||
End Sub ' TraceArguments
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _TraceLevel(ByVal pvTraceLevel As Variant) As Variant
|
||||
' Convert string trace level to numeric value or the opposite
|
||||
|
||||
Dim vTraces As Variant, i As Integer
|
||||
vTraces = Array(TRACEDEBUG, TRACEINFO, TRACEWARNING, TRACEERRORS, TRACEFATAL, TRACEABORT, TRACEANY)
|
||||
|
||||
Select Case VarType(pvTraceLevel)
|
||||
Case vbString
|
||||
_TraceLevel = 4 ' 4 = Default
|
||||
For i = 0 To UBound(vTraces)
|
||||
If UCase(pvTraceLevel) = UCase(vTraces(i)) Then
|
||||
_TraceLevel = i + 1
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
|
||||
If pvTraceLevel < 1 Or pvTraceLevel > UBound(vTraces) + 1 Then _TraceLevel = TRACEERRORS Else _TraceLevel = vTraces(pvTraceLevel - 1)
|
||||
End Select
|
||||
|
||||
End Function ' TraceLevel
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,331 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="UtilProperty" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
'**********************************************************************
|
||||
' UtilProperty module
|
||||
'
|
||||
' Module of utilities to manipulate arrays of PropertyValue's.
|
||||
'**********************************************************************
|
||||
|
||||
'**********************************************************************
|
||||
' Copyright (c) 2003-2004 Danny Brewer
|
||||
' d29583@groovegarden.com
|
||||
'**********************************************************************
|
||||
|
||||
'**********************************************************************
|
||||
' If you make changes, please append to the change log below.
|
||||
'
|
||||
' Change Log
|
||||
' Danny Brewer Revised 2004-02-25-01
|
||||
' Jean-Pierre Ledure Adapted to Access2Base coding conventions
|
||||
' PropValuesToStr rewritten and addition of StrToPropValues
|
||||
' Bug corrected on date values
|
||||
' Addition of support of 2-dimensional arrays
|
||||
' Support of empty arrays to allow JSON conversions
|
||||
'**********************************************************************
|
||||
|
||||
Option Explicit
|
||||
|
||||
Private Const cstHEADER = "### PROPERTYVALUES ###"
|
||||
Private Const cstEMPTYARRAY = "### EMPTY ARRAY ###"
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue
|
||||
' Create and return a new com.sun.star.beans.PropertyValue.
|
||||
|
||||
Dim oPropertyValue As New com.sun.star.beans.PropertyValue
|
||||
|
||||
If Not IsMissing(psName) Then oPropertyValue.Name = psName
|
||||
If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue)
|
||||
_MakePropertyValue() = oPropertyValue
|
||||
|
||||
End Function ' _MakePropertyValue V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant
|
||||
' Date BASIC variables give error. Change them to strings
|
||||
' Empty arrays should be replaced by cstEMPTYARRAY
|
||||
|
||||
If VarType(pvValue) = vbDate Then
|
||||
_CheckPropertyValue = Utils._CStr(pvValue, False)
|
||||
ElseIf IsArray(pvValue) Then
|
||||
If UBound(pvValue, 1) < LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue
|
||||
Else
|
||||
_CheckPropertyValue = pvValue
|
||||
End If
|
||||
|
||||
End Function ' _CheckPropertyValue
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer
|
||||
' Return the number of PropertyValue's in an array.
|
||||
' Parameters:
|
||||
' pvPropertyValuesArray - an array of PropertyValue's, that is an array of com.sun.star.beans.PropertyValue.
|
||||
' Returns zero if the array contains no elements.
|
||||
|
||||
Dim iNumProperties As Integer
|
||||
If Not IsArray(pvPropertyValuesArray) Then iNumProperties = 0 Else iNumProperties = UBound(pvPropertyValuesArray) + 1
|
||||
_NumPropertyValues() = iNumProperties
|
||||
|
||||
End Function ' _NumPropertyValues V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _FindPropertyIndex(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String ) As Integer
|
||||
' Find a particular named property from an array of PropertyValue's.
|
||||
' Finds the index in the array of PropertyValue's and returns it, or returns -1 if it was not found.
|
||||
|
||||
Dim iNumProperties As Integer, i As Integer, vProp As Variant
|
||||
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
|
||||
For i = 0 To iNumProperties - 1
|
||||
vProp = pvPropertyValuesArray(i)
|
||||
If UCase(vProp.Name) = UCase(psPropName) Then
|
||||
_FindPropertyIndex() = i
|
||||
Exit Function
|
||||
EndIf
|
||||
Next i
|
||||
_FindPropertyIndex() = -1
|
||||
|
||||
End Function ' _FindPropertyIndex V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _FindProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String) As com.sun.star.beans.PropertyValue
|
||||
' Find a particular named property from an array of PropertyValue's.
|
||||
' Finds the PropertyValue and returns it, or returns Null if not found.
|
||||
|
||||
Dim iPropIndex As Integer, vProp As Variant
|
||||
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
|
||||
If iPropIndex >= 0 Then
|
||||
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
|
||||
_FindProperty() = vProp
|
||||
EndIf
|
||||
|
||||
End Function ' _FindProperty V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _GetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, Optional pvDefaultValue) As Variant
|
||||
' Get the value of a particular named property from an array of PropertyValue's.
|
||||
' vDefaultValue - This value is returned if the property is not found in the array.
|
||||
|
||||
Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Variant, i As Integer, j As Integer
|
||||
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
|
||||
If iPropIndex >= 0 Then
|
||||
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
|
||||
vValue = vProp.Value ' get the value from the PropertyValue
|
||||
If VarType(vValue) = vbString Then
|
||||
If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue
|
||||
ElseIf IsArray(vValue) Then
|
||||
If IsArray(vValue(0)) Then ' Array of arrays
|
||||
vMatrix = Array()
|
||||
ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0)))
|
||||
For i = 0 To UBound(vValue)
|
||||
For j = 0 To UBound(vValue(0))
|
||||
vMatrix(i, j) = vValue(i)(j)
|
||||
Next j
|
||||
Next i
|
||||
_GetPropertyValue() = vMatrix
|
||||
Else
|
||||
_GetPropertyValue() = vValue ' Simple vector OK
|
||||
End If
|
||||
Else
|
||||
_GetPropertyValue() = vValue
|
||||
End If
|
||||
Else
|
||||
If IsMissing(pvDefaultValue) Then pvDefaultValue = Null
|
||||
_GetPropertyValue() = pvDefaultValue
|
||||
EndIf
|
||||
|
||||
End Function ' _GetPropertyValue V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Sub _SetPropertyValue(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String, ByVal pvValue As Variant)
|
||||
' Set the value of a particular named property from an array of PropertyValue's.
|
||||
|
||||
Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer
|
||||
|
||||
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
|
||||
If iPropIndex >= 0 Then
|
||||
' Found, the PropertyValue is already in the array. Just modify its value.
|
||||
vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript
|
||||
vProp.Value = _CheckPropertyValue(pvValue) ' set the property value.
|
||||
pvPropertyValuesArray(iPropIndex) = vProp ' put it back into array
|
||||
Else
|
||||
' Not found, the array contains no PropertyValue with this name. Append new element to array.
|
||||
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
|
||||
If iNumProperties = 0 Then
|
||||
pvPropertyValuesArray = Array(_MakePropertyValue(psPropName, pvValue))
|
||||
Else
|
||||
' Make array larger.
|
||||
Redim Preserve pvPropertyValuesArray(iNumProperties)
|
||||
' Assign new PropertyValue
|
||||
pvPropertyValuesArray(iNumProperties) = _MakePropertyValue(psPropName, pvValue)
|
||||
EndIf
|
||||
EndIf
|
||||
|
||||
End Sub ' _SetPropertyValue V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Sub _DeleteProperty(ByRef pvPropertyValuesArray As Variant, ByVal psPropName As String)
|
||||
' Delete a particular named property from an array of PropertyValue's.
|
||||
|
||||
Dim iPropIndex As Integer
|
||||
iPropIndex = _FindPropertyIndex(pvPropertyValuesArray, psPropName)
|
||||
If iPropIndex >= 0 Then _DeleteIndexedProperty(pvPropertyValuesArray, iPropIndex)
|
||||
|
||||
End Sub ' _DeletePropertyValue V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Sub _DeleteIndexedProperty(ByRef pvPropertyValuesArray As Variant, ByVal piPropIndex As Integer)
|
||||
' Delete a particular indexed property from an array of PropertyValue's.
|
||||
|
||||
Dim iNumProperties As Integer, i As Integer
|
||||
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
|
||||
|
||||
' Did we find it?
|
||||
If piPropIndex < 0 Then
|
||||
' Do nothing
|
||||
ElseIf iNumProperties = 1 Then
|
||||
' Just return a new empty array
|
||||
pvPropertyValuesArray = Array()
|
||||
Else
|
||||
' If it is NOT the last item in the array, then shift other elements down into it's position.
|
||||
If piPropIndex < iNumProperties - 1 Then
|
||||
' Bump items down lower in the array.
|
||||
For i = piPropIndex To iNumProperties - 2
|
||||
pvPropertyValuesArray(i) = pvPropertyValuesArray(i + 1)
|
||||
Next i
|
||||
EndIf
|
||||
' Redimension the array to have one fewer element.
|
||||
Redim Preserve pvPropertyValuesArray(iNumProperties - 2)
|
||||
EndIf
|
||||
|
||||
End Sub ' _DeleteIndexedProperty V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _PropValuesToStr(ByRef pvPropertyValuesArray As Variant) As String
|
||||
' Return a string with dumped content of the array of PropertyValue's.
|
||||
' SYNTAX:
|
||||
' NameOfProperty = This is a string (or 12 or 2016-12-31 12:05 or 123.45 or -0.12E-05 ...)
|
||||
' NameOfArray = (10)
|
||||
' 1;2;3;4;5;6;7;8;9;10
|
||||
' NameOfMatrix = (2,10)
|
||||
' 1;2;3;4;5;6;7;8;9;10
|
||||
' A;B;C;D;E;F;G;H;I;J
|
||||
' Semicolons and backslashes are escaped with a backslash (see _CStr and _CVar functions)
|
||||
|
||||
Dim iNumProperties As Integer, sResult As String, i As Integer, j As Integer, vProp As Variant
|
||||
Dim sName As String, vValue As Variant, iType As Integer
|
||||
Dim cstLF As String
|
||||
|
||||
cstLF = vbLf()
|
||||
iNumProperties = _NumPropertyValues(pvPropertyValuesArray)
|
||||
|
||||
sResult = cstHEADER & cstLF
|
||||
For i = 0 To iNumProperties - 1
|
||||
vProp = pvPropertyValuesArray(i)
|
||||
sName = vProp.Name
|
||||
vValue = vProp.Value
|
||||
iType = VarType(vValue)
|
||||
Select Case iType
|
||||
Case < vbArray ' Scalar
|
||||
sResult = sResult & sName & " = " & Utils._CStr(vValue, False) & cstLF
|
||||
Case Else ' Vector or matrix
|
||||
If uBound(vValue, 1) < 0 Then
|
||||
sResult = sResult & sName & " = (0)" & cstLF
|
||||
' 1-dimension but vector of vectors must also be considered
|
||||
ElseIf VarType(vValue(0)) >= vbArray Then
|
||||
sResult = sResult & sName & " = (" & UBound(vValue) + 1 & "," & UBound(vValue(0)) + 1 & ")" & cstLF
|
||||
For j = 0 To UBound(vValue)
|
||||
sResult = sResult & Utils._CStr(vValue(j), False) & cstLF
|
||||
Next j
|
||||
Else
|
||||
sResult = sResult & sName & " = (" & UBound(vValue, 1) + 1 & ")" & cstLF
|
||||
sResult = sResult & Utils._CStr(vValue, False) & cstLF
|
||||
End If
|
||||
End Select
|
||||
Next i
|
||||
|
||||
_PropValuesToStr() = Left(sResult, Len(sResult) - 1) ' Remove last LF
|
||||
|
||||
End Function ' _PropValuesToStr V1.3.0
|
||||
|
||||
REM =======================================================================================================================
|
||||
Public Function _StrToPropValues(psString) As Variant
|
||||
' Return an array of PropertyValue's rebuilt from the string parameter
|
||||
|
||||
Dim vString() As Variant, i As Integer,iArray As Integer, iRows As Integer, iCols As Integer
|
||||
Dim lPosition As Long, sName As String, vValue As Variant, vResult As Variant, sDim As String
|
||||
Dim lSearch As Long
|
||||
Dim cstLF As String
|
||||
Const cstEqualArray = " = (", cstEqual = " = "
|
||||
|
||||
cstLF = Chr(10)
|
||||
_StrToPropValues = Array()
|
||||
vResult = Array()
|
||||
|
||||
If psString = "" Then Exit Function
|
||||
vString = Split(psString, cstLF)
|
||||
If UBound(vString) <= 0 Then Exit Function ' There must be at least one name-value pair
|
||||
If vString(0) <> cstHEADER Then Exit Function ' Check origin
|
||||
|
||||
iArray = -1
|
||||
For i = 1 To UBound(vString)
|
||||
If vString(i) <> "" Then ' Skip empty lines
|
||||
If iArray < 0 Then ' Not busy with array row
|
||||
lPosition = 1
|
||||
sName = Utils._RegexSearch(vString(i), "^\b\w+\b", lPosition) ' Identifier
|
||||
If sName = "" Then Exit Function
|
||||
If InStr(vString(i), cstEqualArray) = lPosition + Len(sName) Then ' Start array processing
|
||||
lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
|
||||
sDim = Utils._RegexSearch(vString(i), "\([0-9]+\)", lSearch) ' e.g. (10)
|
||||
If sDim = "(0)" Then ' Empty array
|
||||
iRows = -1
|
||||
vValue = Array()
|
||||
_SetPropertyValue(vResult, sName, vValue)
|
||||
ElseIf sDim <> "" Then ' Vector with content
|
||||
iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
|
||||
iRows = 0
|
||||
ReDim vValue(0 To iCols - 1)
|
||||
iArray = 0
|
||||
Else ' Matrix with content
|
||||
lSearch = lPosition + Len(sName) + Len(cstEqualArray) - 1
|
||||
sDim = Utils._RegexSearch(vString(i), "\([0-9]+,", lSearch) ' e.g. (10,
|
||||
iRows = CInt(Mid(sDim, 2, Len(sDim) - 2))
|
||||
sDim = Utils._RegexSearch(vString(i), ",[0-9]+\)", lSearch) ' e.g. ,20)
|
||||
iCols = CInt(Mid(sDim, 2, Len(sDim) - 2))
|
||||
ReDim vValue(0 To iRows - 1)
|
||||
iArray = 0
|
||||
End If
|
||||
ElseIf InStr(vString(i), cstEqual) = lPosition + Len(sName) Then
|
||||
vValue = Utils._CVar(Mid(vString(i), Len(sName) + Len(cstEqual) + 1))
|
||||
_SetPropertyValue(vResult, sName, vValue)
|
||||
Else
|
||||
Exit Function
|
||||
End If
|
||||
Else ' Line is an array row
|
||||
If iRows = 0 Then
|
||||
vValue = Utils._CVar(vString(i), True) ' Keep dates as strings
|
||||
iArray = -1
|
||||
_SetPropertyValue(vResult, sName, vValue)
|
||||
Else
|
||||
vValue(iArray) = Utils._CVar(vString(i), True)
|
||||
If iArray < iRows - 1 Then
|
||||
iArray = iArray + 1
|
||||
Else
|
||||
iArray = -1
|
||||
_SetPropertyValue(vResult, sName, vValue)
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
Next i
|
||||
|
||||
_StrToPropValues = vResult
|
||||
|
||||
End Function
|
||||
|
||||
</script:module>
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,25 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="_License" script:language="StarBasic">
|
||||
' Copyright 2012-2017 Jean-Pierre LEDURE
|
||||
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
' Access2Base is distributed in the hope that it will be useful,
|
||||
' but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
' Access2Base is free software; you can redistribute it and/or modify it under the terms of either (at your option):
|
||||
'
|
||||
' 1) The Mozilla Public License, v. 2.0. If a copy of the MPL was not
|
||||
' distributed with this file, you can obtain one at http://mozilla.org/MPL/2.0/ .
|
||||
'
|
||||
' 2) The GNU Lesser General Public License as published by
|
||||
' the Free Software Foundation, either version 3 of the License, or
|
||||
' (at your option) any later version. If a copy of the LGPL was not
|
||||
' distributed with this file, see http://www.gnu.org/licenses/ .
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,395 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="acConstants" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM Access2Base -----------------------------------------------------
|
||||
Global Const Access2Base_Version = "7.1.0" ' Alignment on LibreOffice versions
|
||||
|
||||
REM AcCloseSave
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acSaveNo = 2
|
||||
Global Const acSavePrompt = 0
|
||||
Global Const acSaveYes = 1
|
||||
|
||||
REM AcFormView
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acDesign = 1
|
||||
Global Const acNormal = 0
|
||||
Global Const acPreview = 2
|
||||
|
||||
REM AcFormOpenDataMode
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acFormAdd = 0
|
||||
Global Const acFormEdit = 1
|
||||
Global Const acFormPropertySettings = -1
|
||||
Global Const acFormReadOnly = 2
|
||||
|
||||
REM acView
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acViewDesign = 1
|
||||
Global Const acViewNormal = 0
|
||||
Global Const acViewPreview = 2
|
||||
|
||||
REM acOpenDataMode
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acAdd = 0
|
||||
Global Const acEdit = 1
|
||||
Global Const acReadOnly = 2
|
||||
|
||||
REM AcObjectType
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acDefault = -1
|
||||
Global Const acDiagram = 8
|
||||
Global Const acForm = 2
|
||||
Global Const acQuery = 1
|
||||
Global Const acReport = 3
|
||||
Global Const acTable = 0
|
||||
' Unexisting in MS/Access
|
||||
Global Const acBasicIDE = 101
|
||||
Global Const acDatabaseWindow = 102
|
||||
Global Const acDocument = 111
|
||||
Global Const acWelcome = 112
|
||||
' Subtype if acDocument
|
||||
Global Const docWriter = "Writer"
|
||||
Global Const docCalc = "Calc"
|
||||
Global Const docImpress = "Impress"
|
||||
Global Const docDraw = "Draw"
|
||||
Global Const docMath = "Math"
|
||||
|
||||
REM AcWindowMode
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acDialog = 3
|
||||
Global Const acHidden = 1
|
||||
Global Const acIcon = 2
|
||||
Global Const acWindowNormal = 0
|
||||
|
||||
REM VarType constants
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const vbEmpty = 0
|
||||
Global Const vbNull = 1
|
||||
Global Const vbInteger = 2
|
||||
Global Const vbLong = 3
|
||||
Global Const vbSingle = 4
|
||||
Global Const vbDouble = 5
|
||||
Global Const vbCurrency = 6
|
||||
Global Const vbDate = 7
|
||||
Global Const vbString = 8
|
||||
Global Const vbObject = 9
|
||||
Global Const vbError = 10
|
||||
Global Const vbBoolean = 11
|
||||
Global Const vbVariant = 12
|
||||
Global Const vbByte = 17
|
||||
Global Const vbUShort = 18
|
||||
Global Const vbULong = 19
|
||||
Global Const vbBigint = 35
|
||||
Global Const vbDecimal = 37
|
||||
Global Const vbArray = 8192
|
||||
|
||||
REM MsgBox constants
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const vbOKOnly = 0 ' OK button only (default)
|
||||
Global Const vbOKCancel = 1 ' OK and Cancel buttons
|
||||
Global Const vbAbortRetryIgnore = 2 ' Abort, Retry, and Ignore buttons
|
||||
Global Const vbYesNoCancel = 3 ' Yes, No, and Cancel buttons
|
||||
Global Const vbYesNo = 4 ' Yes and No buttons
|
||||
Global Const vbRetryCancel = 5 ' Retry and Cancel buttons
|
||||
Global Const vbCritical = 16 ' Critical message
|
||||
Global Const vbQuestion = 32 ' Warning query
|
||||
Global Const vbExclamation = 48 ' Warning message
|
||||
Global Const vbInformation = 64 ' Information message
|
||||
Global Const vbDefaultButton1 = 128 ' First button is default (default) (VBA: 0)
|
||||
Global Const vbDefaultButton2 = 256 ' Second button is default
|
||||
Global Const vbDefaultButton3 = 512 ' Third button is default
|
||||
Global Const vbApplicationModal = 0 ' Application modal message box (default)
|
||||
REM MsgBox Return Values
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const vbOK = 1 ' OK button pressed
|
||||
Global Const vbCancel = 2 ' Cancel button pressed
|
||||
Global Const vbAbort = 3 ' Abort button pressed
|
||||
Global Const vbRetry = 4 ' Retry button pressed
|
||||
Global Const vbIgnore = 5 ' Ignore button pressed
|
||||
Global Const vbYes = 6 ' Yes button pressed
|
||||
Global Const vbNo = 7 ' No button pressed
|
||||
|
||||
REM Dialogs Return Values
|
||||
REM ------------------------------------------------------------------
|
||||
Global Const dlgOK = 1 ' OK button pressed
|
||||
Global Const dlgCancel = 0 ' Cancel button pressed
|
||||
|
||||
REM Control Types
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acCheckBox = 5
|
||||
Global Const acComboBox = 7
|
||||
Global Const acCommandButton = 2 : Global Const acToggleButton = 122
|
||||
Global Const acCurrencyField = 18
|
||||
Global Const acDateField = 15
|
||||
Global Const acFileControl = 12
|
||||
Global Const acFixedLine = 24 ' FREE ENTRY (USEFUL IN DIALOGS)
|
||||
Global Const acFixedText = 10 : Global Const acLabel = 10
|
||||
Global Const acFormattedField = 1 ' FREE ENTRY TAKEN TO NOT CONFUSE WITH acTextField
|
||||
Global Const acGridControl = 11
|
||||
Global Const acGroupBox = 8 : Global Const acOptionGroup = 8
|
||||
Global Const acHiddenControl = 13
|
||||
Global Const acImageButton = 4
|
||||
Global Const acImageControl = 14 : Global Const acImage = 14
|
||||
Global Const acListBox = 6
|
||||
Global Const acNavigationBar = 22
|
||||
Global Const acNumericField = 17
|
||||
Global Const acPatternField = 19
|
||||
Global Const acProgressBar = 23 ' FREE ENTRY (USEFUL IN DIALOGS)
|
||||
Global Const acRadioButton = 3 : Global Const acOptionButton = 3
|
||||
Global Const acScrollBar = 20
|
||||
Global Const acSpinButton = 21
|
||||
Global Const acSubform = 112
|
||||
Global Const acTextField = 9 : Global Const acTextBox = 9
|
||||
Global Const acTimeField = 16
|
||||
|
||||
REM AcRecord
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acFirst = 2
|
||||
Global Const acGoTo = 4
|
||||
Global Const acLast = 3
|
||||
Global Const acNewRec = 5
|
||||
Global Const acNext = 1
|
||||
Global Const acPrevious = 0
|
||||
|
||||
REM FindRecord
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acAnywhere = 0
|
||||
Global Const acEntire = 1
|
||||
Global Const acStart = 2
|
||||
Global Const acDown = 1
|
||||
Global Const acSearchAll = 2
|
||||
Global Const acUp = 0
|
||||
Global Const acAll = 0
|
||||
Global Const acCurrent = -1
|
||||
|
||||
REM AcDataObjectType
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acActiveDataObject = -1
|
||||
Global Const acDataForm = 2
|
||||
Global Const acDataQuery = 1
|
||||
Global Const acDataServerView = 7
|
||||
Global Const acDataStoredProcedure = 9
|
||||
Global Const acDataTable = 0
|
||||
|
||||
REM AcQuitOption
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acQuitPrompt = 0
|
||||
Global Const acQuitSaveAll = 1
|
||||
Global Const acQuitSaveNone = 2
|
||||
|
||||
REM AcCommand
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acCmdAboutMicrosoftAccess = 35
|
||||
Global Const acCmdAboutOpenOffice = 35
|
||||
Global Const acCmdAboutLibreOffice = 35
|
||||
Global Const acCmdVisualBasicEditor = 525
|
||||
Global Const acCmdBringToFront = 52
|
||||
Global Const acCmdClose = 58
|
||||
Global Const acCmdToolbarsCustomize = 165
|
||||
Global Const acCmdChangeToCommandButton = 501
|
||||
Global Const acCmdChangeToCheckBox = 231
|
||||
Global Const acCmdChangeToComboBox = 230
|
||||
Global Const acCmdChangeToTextBox = 227
|
||||
Global Const acCmdChangeToLabel = 228
|
||||
Global Const acCmdChangeToImage = 234
|
||||
Global Const acCmdChangeToListBox = 229
|
||||
Global Const acCmdChangeToOptionButton = 233
|
||||
Global Const acCmdCopy = 190
|
||||
Global Const acCmdCut = 189
|
||||
Global Const acCmdCreateRelationship = 150
|
||||
Global Const acCmdDelete = 337
|
||||
Global Const acCmdDatabaseProperties = 256
|
||||
Global Const acCmdSQLView = 184
|
||||
Global Const acCmdRemove = 366
|
||||
Global Const acCmdDesignView = 183
|
||||
Global Const acCmdFormView = 281
|
||||
Global Const acCmdNewObjectForm = 136
|
||||
Global Const acCmdNewObjectTable = 134
|
||||
Global Const acCmdNewObjectView = 350
|
||||
Global Const acCmdOpenDatabase = 25
|
||||
Global Const acCmdNewObjectQuery = 135
|
||||
Global Const acCmdShowAllRelationships = 149
|
||||
Global Const acCmdNewObjectReport = 137
|
||||
Global Const acCmdSelectAll = 333
|
||||
Global Const acCmdRemoveTable = 84
|
||||
Global Const acCmdOpenTable = 221
|
||||
Global Const acCmdRename = 143
|
||||
Global Const acCmdDeleteRecord = 223
|
||||
Global Const acCmdApplyFilterSort = 93
|
||||
Global Const acCmdSnapToGrid = 62
|
||||
Global Const acCmdViewGrid = 63
|
||||
Global Const acCmdInsertHyperlink = 259
|
||||
Global Const acCmdMaximumRecords = 508
|
||||
Global Const acCmdObjectBrowser = 200
|
||||
Global Const acCmdPaste = 191
|
||||
Global Const acCmdPasteSpecial = 64
|
||||
Global Const acCmdPrint = 340
|
||||
Global Const acCmdPrintPreview = 54
|
||||
Global Const acCmdSaveRecord = 97
|
||||
Global Const acCmdFind = 30
|
||||
Global Const acCmdUndo = 292
|
||||
Global Const acCmdRefresh = 18
|
||||
Global Const acCmdRemoveFilterSort = 144
|
||||
Global Const acCmdRunMacro = 31
|
||||
Global Const acCmdSave = 20
|
||||
Global Const acCmdSaveAs = 21
|
||||
Global Const acCmdSelectAllRecords = 109
|
||||
Global Const acCmdSendToBack = 53
|
||||
Global Const acCmdSortDescending = 164
|
||||
Global Const acCmdSortAscending = 163
|
||||
Global Const acCmdTabOrder = 41
|
||||
Global Const acCmdDatasheetView = 282
|
||||
Global Const acCmdZoomSelection = 371
|
||||
|
||||
REM AcSendObjectType
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acSendForm = 2
|
||||
Global Const acSendNoObject = -1
|
||||
Global Const acSendQuery = 1
|
||||
Global Const acSendReport = 3
|
||||
Global Const acSendTable = 0
|
||||
|
||||
REM AcOutputObjectType
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acOutputTable = 0
|
||||
Global Const acOutputQuery = 1
|
||||
Global Const acOutputForm = 2
|
||||
Global Const acOutputArray = -1
|
||||
|
||||
REM AcEncoding
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acUTF8Encoding = 76
|
||||
|
||||
REM AcFormat
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acFormatPDF = "writer_pdf_Export"
|
||||
Global Const acFormatODT = "writer8"
|
||||
Global Const acFormatDOC = "MS Word 97"
|
||||
Global Const acFormatHTML = "HTML"
|
||||
Global Const acFormatODS = "calc8"
|
||||
Global Const acFormatXLS = "MS Excel 97"
|
||||
Global Const acFormatXLSX = "Calc MS Excel 2007 XML"
|
||||
Global Const acFormatTXT = "Text - txt - csv (StarCalc)"
|
||||
|
||||
REM AcExportQuality
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acExportQualityPrint = 0
|
||||
Global Const acExportQualityScreen = 1
|
||||
|
||||
REM AcSysCmdAction
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acSysCmdAccessDir = 9
|
||||
Global Const acSysCmdAccessVer = 7
|
||||
Global Const acSysCmdClearHelpTopic = 11
|
||||
Global Const acSysCmdClearStatus = 5
|
||||
Global Const acSysCmdGetObjectState = 10
|
||||
Global Const acSysCmdGetWorkgroupFile = 13
|
||||
Global Const acSysCmdIniFile = 8
|
||||
Global Const acSysCmdInitMeter = 1
|
||||
Global Const acSysCmdProfile = 12
|
||||
Global Const acSysCmdRemoveMeter = 3
|
||||
Global Const acSysCmdRuntime = 6
|
||||
Global Const acSysCmdSetStatus = 4
|
||||
Global Const acSysCmdUpdateMeter = 2
|
||||
|
||||
REM Type property
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const dbBigInt = 16
|
||||
Global Const dbBinary = 9
|
||||
Global Const dbBoolean = 1
|
||||
Global Const dbByte = 2
|
||||
Global Const dbChar = 18
|
||||
Global Const dbCurrency = 5
|
||||
Global Const dbDate = 8
|
||||
Global Const dbDecimal = 20
|
||||
Global Const dbDouble = 7
|
||||
Global Const dbFloat = 21
|
||||
Global Const dbGUID = 15
|
||||
Global Const dbInteger = 3
|
||||
Global Const dbLong = 4
|
||||
Global Const dbLongBinary = 11 ' (OLE Object)
|
||||
Global Const dbMemo= 12
|
||||
Global Const dbNumeric = 19
|
||||
Global Const dbSingle = 6
|
||||
Global Const dbText = 10
|
||||
Global Const dbTime = 22
|
||||
Global Const dbTimeStamp = 23
|
||||
Global Const dbVarBinary = 17
|
||||
Global Const dbUndefined = -1
|
||||
|
||||
REM Attributes property
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const dbAutoIncrField = 16
|
||||
Global Const dbDescending = 1
|
||||
Global Const dbFixedField = 1
|
||||
Global Const dbHyperlinkField = 32768
|
||||
Global Const dbSystemField = 8192
|
||||
Global Const dbUpdatableField = 32
|
||||
Global Const dbVariableField = 2
|
||||
|
||||
REM OpenRecordset
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const dbOpenForwardOnly = 8
|
||||
Global Const dbSQLPassThrough = 64
|
||||
Global Const dbReadOnly = 4
|
||||
|
||||
REM Query types
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const dbQAction = 240
|
||||
Global Const dbQAppend = 64
|
||||
Global Const dbQDDL = 4 '96
|
||||
Global Const dbQDelete = 32
|
||||
Global Const dbQMakeTable = 128 '80
|
||||
Global Const dbQSelect = 0
|
||||
Global Const dbQSetOperation = 8 '128
|
||||
Global Const dbQSQLPassThrough = 1 '112
|
||||
Global Const dbQUpdate = 16 '48
|
||||
|
||||
REM Edit mode
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const dbEditNone = 0
|
||||
Global Const dbEditInProgress = 1
|
||||
Global Const dbEditAdd = 2
|
||||
|
||||
REM Toolbars
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const msoBarTypeNormal = 0 ' Usual toolbar
|
||||
Global Const msoBarTypeMenuBar = 1 ' Menu bar
|
||||
Global Const msoBarTypePopup = 2 ' Shortcut menu
|
||||
Global Const msoBarTypeStatusBar = 11 ' Status bar
|
||||
Global Const msoBarTypeFloater = 12 ' Floating window
|
||||
|
||||
Global Const msoControlButton = 1 ' Command button
|
||||
Global Const msoControlPopup = 10 ' Popup, submenu
|
||||
|
||||
REM New Lines
|
||||
REM -----------------------------------------------------------------
|
||||
Public Function vbCr() As String : vbCr = Chr(13) : End Function
|
||||
Public Function vbLf() As String : vbLf = Chr(10) : End Function
|
||||
Public Function vbNewLine() As String
|
||||
Const cstWindows = 1
|
||||
If GetGuiType() = cstWindows Then vbNewLine = vbCR & vbLF Else vbNewLine = vbLF
|
||||
End Function ' vbNewLine V1.4.0
|
||||
Public Function vbTab() As String : vbTab = Chr(9) : End Function
|
||||
|
||||
REM Module types
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const acClassModule = 1
|
||||
Global Const acStandardModule = 0
|
||||
|
||||
REM (Module) procedure types
|
||||
REM -----------------------------------------------------------------
|
||||
Global Const vbext_pk_Get = 1 ' A Property Get procedure
|
||||
Global Const vbext_pk_Let = 2 ' A Property Let procedure
|
||||
Global Const vbext_pk_Proc = 0 ' A Sub or Function procedure
|
||||
Global Const vbext_pk_Set = 3 ' A Property Set procedure
|
||||
|
||||
</script:module>
|
||||
@@ -0,0 +1,6 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd">
|
||||
<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Access2Base" library:readonly="false" library:passwordprotected="false">
|
||||
<library:element library:name="dlgTrace"/>
|
||||
<library:element library:name="dlgFormat"/>
|
||||
</library:library>
|
||||
@@ -0,0 +1,19 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE dlg:window PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "dialog.dtd">
|
||||
<dlg:window xmlns:dlg="http://openoffice.org/2000/dialog" xmlns:script="http://openoffice.org/2000/script" dlg:id="dlgFormat" dlg:left="246" dlg:top="119" dlg:width="153" dlg:height="40" dlg:help-text="Export the form" dlg:closeable="true" dlg:moveable="true" dlg:title="OutputTo">
|
||||
<dlg:bulletinboard>
|
||||
<dlg:combobox dlg:id="cboFormat" dlg:tab-index="0" dlg:left="4" dlg:top="18" dlg:width="71" dlg:height="8" dlg:help-text="Format in which the form should be exported" dlg:value="PDF" dlg:spin="true">
|
||||
<dlg:menupopup>
|
||||
<dlg:menuitem dlg:value="PDF"/>
|
||||
<dlg:menuitem dlg:value="ODT"/>
|
||||
<dlg:menuitem dlg:value="DOC"/>
|
||||
<dlg:menuitem dlg:value="HTML"/>
|
||||
</dlg:menupopup>
|
||||
</dlg:combobox>
|
||||
<dlg:text dlg:id="lblFormat" dlg:tab-index="1" dlg:left="4" dlg:top="7" dlg:width="100" dlg:height="9" dlg:help-text="Format in which the form should be exported" dlg:value="Select the output format"/>
|
||||
<dlg:button dlg:id="cmdOK" dlg:tab-index="2" dlg:left="111" dlg:top="5" dlg:width="35" dlg:height="12" dlg:help-text="Validate your choice" dlg:default="true" dlg:value="OK" dlg:button-type="ok">
|
||||
<script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Access2Base.Trace._TraceOK?language=Basic&location=application" script:language="Script"/>
|
||||
</dlg:button>
|
||||
<dlg:button dlg:id="cmdCancel" dlg:tab-index="3" dlg:left="111" dlg:top="20" dlg:width="35" dlg:height="12" dlg:help-text="Cancel and close the dialog" dlg:value="Cancel" dlg:button-type="cancel"/>
|
||||
</dlg:bulletinboard>
|
||||
</dlg:window>
|
||||
@@ -0,0 +1,33 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE dlg:window PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "dialog.dtd">
|
||||
<dlg:window xmlns:dlg="http://openoffice.org/2000/dialog" xmlns:script="http://openoffice.org/2000/script" dlg:id="dlgTrace" dlg:left="81" dlg:top="63" dlg:width="438" dlg:height="154" dlg:help-text="Manage the console file and its entries" dlg:closeable="true" dlg:moveable="true" dlg:title="Console">
|
||||
<dlg:styles>
|
||||
<dlg:style dlg:style-id="0" dlg:font-name="Courier New" dlg:font-stylename="Regular" dlg:font-family="modern"/>
|
||||
<dlg:style dlg:style-id="1" dlg:look="simple"/>
|
||||
<dlg:style dlg:style-id="2" dlg:background-color="0xe6e6e6" dlg:border="none"/>
|
||||
</dlg:styles>
|
||||
<dlg:bulletinboard>
|
||||
<dlg:text dlg:id="lblEntries" dlg:tab-index="3" dlg:left="265" dlg:top="134" dlg:width="130" dlg:height="9" dlg:help-text="Clear the list and resize the circular buffer" dlg:value="Set max number of entries" dlg:align="right"/>
|
||||
<dlg:numericfield dlg:id="numEntries" dlg:tab-index="4" dlg:left="399" dlg:top="129" dlg:width="28" dlg:height="16" dlg:help-text="Clear the list and resize the circular buffer" dlg:decimal-accuracy="0" dlg:value="20" dlg:value-min="5" dlg:value-max="999" dlg:spin="true"/>
|
||||
<dlg:textfield dlg:style-id="0" dlg:id="txtTraceLog" dlg:tab-index="0" dlg:left="9" dlg:top="20" dlg:width="360" dlg:height="105" dlg:help-text="Text can be selected, copied, ..." dlg:hscroll="true" dlg:vscroll="true" dlg:multiline="true" dlg:readonly="true" dlg:value="--- Log file is empty ---"/>
|
||||
<dlg:checkbox dlg:style-id="1" dlg:id="chkClear" dlg:tab-index="5" dlg:left="58" dlg:top="133" dlg:width="6" dlg:height="9" dlg:help-text="Clear the list" dlg:value="Clear" dlg:checked="false"/>
|
||||
<dlg:button dlg:id="cmdCancel" dlg:tab-index="6" dlg:left="381" dlg:top="38" dlg:width="40" dlg:height="12" dlg:help-text="Cancel and close the dialog" dlg:value="Cancel" dlg:button-type="cancel"/>
|
||||
<dlg:text dlg:id="lblClear" dlg:tab-index="7" dlg:left="9" dlg:top="133" dlg:width="46" dlg:height="9" dlg:help-text="Clear the list" dlg:value="Clear the list" dlg:align="right"/>
|
||||
<dlg:text dlg:id="lblMinLevel" dlg:tab-index="8" dlg:left="74" dlg:top="133" dlg:width="130" dlg:height="9" dlg:help-text="Register only logging requests above given level" dlg:value="Set minimal trace level" dlg:align="right"/>
|
||||
<dlg:combobox dlg:id="cboMinLevel" dlg:tab-index="9" dlg:left="209" dlg:top="133" dlg:width="50" dlg:height="9" dlg:help-text="Register only logging requests above given level" dlg:spin="true">
|
||||
<dlg:menupopup>
|
||||
<dlg:menuitem dlg:value="DEBUG"/>
|
||||
<dlg:menuitem dlg:value="INFO"/>
|
||||
<dlg:menuitem dlg:value="WARNING"/>
|
||||
<dlg:menuitem dlg:value="ERROR"/>
|
||||
<dlg:menuitem dlg:value="ABORT"/>
|
||||
</dlg:menupopup>
|
||||
</dlg:combobox>
|
||||
<dlg:button dlg:id="cmdOK" dlg:tab-index="1" dlg:left="381" dlg:top="20" dlg:width="40" dlg:height="12" dlg:help-text="Validate" dlg:default="true" dlg:value="OK" dlg:button-type="ok"/>
|
||||
<dlg:button dlg:id="cmdDump" dlg:tab-index="2" dlg:left="381" dlg:top="68" dlg:width="40" dlg:height="31" dlg:help-text="Choose a file and dump the actual list content in it" dlg:value="Dump to file" dlg:multiline="true">
|
||||
<script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Access2Base.Trace._DumpToFile?language=Basic&location=application" script:language="Script"/>
|
||||
</dlg:button>
|
||||
<dlg:text dlg:id="lblNbEntries" dlg:tab-index="10" dlg:left="9" dlg:top="10" dlg:width="105" dlg:height="7" dlg:help-text="Actual size of list" dlg:value="Actual number of entries:"/>
|
||||
<dlg:numericfield dlg:style-id="2" dlg:id="numNbEntries" dlg:tab-index="11" dlg:left="123" dlg:top="9" dlg:width="17" dlg:height="9" dlg:help-text="Actual size of list" dlg:readonly="true" dlg:decimal-accuracy="0" dlg:value="0"/>
|
||||
</dlg:bulletinboard>
|
||||
</dlg:window>
|
||||
@@ -0,0 +1,34 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd">
|
||||
<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Access2Base" library:readonly="false" library:passwordprotected="false">
|
||||
<library:element library:name="Application"/>
|
||||
<library:element library:name="Methods"/>
|
||||
<library:element library:name="acConstants"/>
|
||||
<library:element library:name="Test"/>
|
||||
<library:element library:name="Trace"/>
|
||||
<library:element library:name="DoCmd"/>
|
||||
<library:element library:name="Utils"/>
|
||||
<library:element library:name="Database"/>
|
||||
<library:element library:name="PropertiesSet"/>
|
||||
<library:element library:name="Collect"/>
|
||||
<library:element library:name="PropertiesGet"/>
|
||||
<library:element library:name="Form"/>
|
||||
<library:element library:name="Python"/>
|
||||
<library:element library:name="_License"/>
|
||||
<library:element library:name="SubForm"/>
|
||||
<library:element library:name="L10N"/>
|
||||
<library:element library:name="OptionGroup"/>
|
||||
<library:element library:name="Event"/>
|
||||
<library:element library:name="Property"/>
|
||||
<library:element library:name="Control"/>
|
||||
<library:element library:name="Dialog"/>
|
||||
<library:element library:name="Field"/>
|
||||
<library:element library:name="DataDef"/>
|
||||
<library:element library:name="Recordset"/>
|
||||
<library:element library:name="TempVar"/>
|
||||
<library:element library:name="Root_"/>
|
||||
<library:element library:name="UtilProperty"/>
|
||||
<library:element library:name="CommandBar"/>
|
||||
<library:element library:name="CommandBarControl"/>
|
||||
<library:element library:name="Module"/>
|
||||
</library:library>
|
||||
Reference in New Issue
Block a user