diff options
Diffstat (limited to 'wizards/source/access2base/Methods.xba')
| -rw-r--r-- | wizards/source/access2base/Methods.xba | 300 |
1 files changed, 300 insertions, 0 deletions
diff --git a/wizards/source/access2base/Methods.xba b/wizards/source/access2base/Methods.xba new file mode 100644 index 000000000..7f809c6c1 --- /dev/null +++ b/wizards/source/access2base/Methods.xba @@ -0,0 +1,300 @@ +<?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>
\ No newline at end of file |