strepsirrhini/office-gobmx
9
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
office-gobmx/wizards/source/access2base/Methods.xba
Jean-Pierre Ledure 1cbd9f7fbe Access2Base - Remove _This in Form and SubForm objects 
The construction in Basic
	Set a._This = a
is useful to export the address of an object to Subs or Functions.
It increases however the risk of memory leaks.
Avoid when avoidable.

Change-Id: I81bf01badf00687526a358eda117a55b12f5d72b
2014-08-22 15:34:58 +02:00

273 lines
No EOL
11 KiB
XML
Raw Blame History

<?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
&apos; Add an item in a Listbox
Utils._SetCalledSub(&quot;AddItem&quot;)
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(&quot;AddItem&quot;)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, &quot;AddItem&quot;, Erl)
AddItem = False
GoTo Exit_Function
End Function &apos; AddItem V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(Optional pvObject As Variant, ByVal Optional pvProperty As Variant) As Boolean
&apos; Return True if pvObject has a valid property called pvProperty (case-insensitive comparison !)
Dim vPropertiesList As Variant
Utils._SetCalledSub(&quot;hasProperty&quot;)
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(&quot;hasProperty&quot;)
Exit Function
End Function &apos; 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
&apos; Execute Move method
Utils._SetCalledSub(&quot;Move&quot;)
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(&quot;Move&quot;)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, &quot;Move&quot;, Erl)
GoTo Exit_Function
End Function &apos; Move V.0.9.1
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenHelpFile()
&apos; Open the help file from the Help menu (IDE only)
Const cstHelpFile = &quot;http://www.access2base.com/access2base.html&quot;
On Local Error Resume Next
Call _ShellExecute(cstHelpFile)
End Function &apos; OpenHelpFile V0.8.5
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
&apos; Return
&apos; a Collection object if pvIndex absent
&apos; 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(&quot;Properties&quot;)
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(&quot;Properties&quot;)
Exit Function
End Function &apos; Properties V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Refresh(Optional pvObject As Variant) As Boolean
&apos; Refresh data with its most recent value in the database in a form or subform
Utils._SetCalledSub(&quot;Refresh&quot;)
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(&quot;Refresh&quot;)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, &quot;Refresh&quot;, Erl)
GoTo Exit_Function
End Function &apos; Refresh V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RemoveItem(Optional pvBox As Variant,ByVal Optional pvIndex) As Boolean
&apos; Remove an item from a Listbox
&apos; Index may be a string value or an index-position
Utils._SetCalledSub(&quot;RemoveItem&quot;)
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(&quot;RemoveItem&quot;)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, &quot;RemoveItem&quot;, Erl)
RemoveItem = False
GoTo Exit_Function
End Function &apos; RemoveItem V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Requery(Optional pvObject As Variant) As Boolean
&apos; Refresh data displayed in a form, subform, combobox or listbox
Utils._SetCalledSub(&quot;Requery&quot;)
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(&quot;Requery&quot;)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, &quot;Requery&quot;, Erl)
GoTo Exit_Function
End Function &apos; Requery V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function SetFocus(Optional pvObject As Variant) As Boolean
&apos; Execute SetFocus method
Utils._SetCalledSub(&quot;setFocus&quot;)
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(&quot;SetFocus&quot;)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, &quot;SetFocus&quot;, Erl)
Goto Exit_Function
Error_Grid:
TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name))
Goto Exit_Function
End Function &apos; SetFocus V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Function _OptionGroup(ByVal pvGroupName As Variant _
, ByVal psParentType As String _
, poComponent As Object _
, poDatabaseForm As Object _
) As Variant
&apos; 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 &apos; Two indexes X-Y coordinates
Dim oView As Object
Const cstPixels = 10 &apos; Tolerance on coordinates when drawed approximately
bFound = False
For i = 0 To poDatabaseForm.GroupCount - 1 &apos; Does a group with the right name exist ?
poDatabaseForm.getGroup(i, vOptionButtons, sGroupName)
If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
bFound = True
Exit For
End If
Next i
If bFound Then
ogGroup = New Optiongroup
ogGroup._Name = sGroupName
ogGroup._ButtonsGroup = vOptionButtons
ogGroup._Count = UBound(vOptionButtons) + 1
ogGroup._ParentType = psParentType
Set ogGroup._ParentComponent = poComponent
ReDim lXY(1, ogGroup._Count - 1)
ReDim iIndex(ogGroup._Count - 1)
For i = 0 To ogGroup._Count - 1 &apos; 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 &apos; 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) &lt; - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) &lt;= cstPixels And lXY(0, i) - lXY(0, j) &lt; - 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,&quot;_OptionGroup&quot;, Erl)
GoTo Exit_Function
End Function &apos; _OptionGroup V1.1.0
</script:module>
Reference in a new issue View git blame Copy permalink