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