<?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>