wizards/source/access2base/Methods.xba

   1 <?xml version="1.0" encoding="UTF-8"?>
   2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
   3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Methods" script:language="StarBasic">
   4 REM =======================================================================================================================
   5 REM ===                                 The Access2Base library is a part of the LibreOffice project.                                                                   ===
   6 REM ===                                 Full documentation is available on http://www.access2base.com                                                                   ===
   7 REM =======================================================================================================================
   8
   9 Option Explicit
  10
  11 REM -----------------------------------------------------------------------------------------------------------------------
  12 Public Function AddItem(Optional pvBox As Variant, ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean
  13 &apos;  Add an item in a Listbox
  14
  15         Utils._SetCalledSub(&quot;AddItem&quot;)
  16         If _ErrorHandler() Then On Local Error Goto Error_Function
  17
  18         If IsMissing(pvBox) Or IsMissing(pvItem) Then Call _TraceArguments()
  19         If IsMissing(pvIndex) Then pvIndex = -1
  20         If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function
  21
  22         AddItem = pvBox.AddItem(pvItem, pvIndex)
  23
  24 Exit_Function:
  25         Utils._ResetCalledSub(&quot;AddItem&quot;)
  26         Exit Function
  27 Error_Function:
  28         TraceError(TRACEABORT, Err, &quot;AddItem&quot;, Erl)
  29         AddItem = False
  30         GoTo Exit_Function
  31 End Function            &apos;  AddItem         V0.9.0
  32
  33 REM -----------------------------------------------------------------------------------------------------------------------
  34 Public Function hasProperty(Optional pvObject As Variant, ByVal Optional pvProperty As Variant) As Boolean
  35 &apos;  Return True if pvObject has a valid property called pvProperty (case-insensitive comparison !)
  36
  37 Dim vPropertiesList As Variant
  38
  39         Utils._SetCalledSub(&quot;hasProperty&quot;)
  40         If IsMissing(pvObject) Or IsMissing(pvProperty) Then Call _TraceArguments()
  41
  42         hasProperty = False
  43         If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _
  44                                                 , OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _
  45                                                 )) Then Goto Exit_Function
  46         If Not Utils._CheckArgument(pvProperty, 2, vbString) Then Goto Exit_Function
  47
  48         hasProperty = pvObject.hasProperty(pvProperty)
  49
  50 Exit_Function:
  51         Utils._ResetCalledSub(&quot;hasProperty&quot;)
  52         Exit Function
  53 End Function    &apos;  hasProperty             V0.9.0
  54
  55 REM -----------------------------------------------------------------------------------------------------------------------
  56 Public Function Move(Optional pvObject As Object _
  57                                                 , ByVal Optional pvLeft As Variant _
  58                                                 , ByVal Optional pvTop As Variant _
  59                                                 , ByVal Optional pvWidth As Variant _
  60                                                 , ByVal Optional pvHeight As Variant _
  61                                                 ) As Variant
  62 &apos;  Execute Move method
  63         Utils._SetCalledSub(&quot;Move&quot;)
  64         If IsMissing(pvObject) Then Call _TraceArguments()
  65         If _ErrorHandler() Then On Local Error Goto Error_Function
  66         Move = False
  67         If Not Utils._CheckArgument(pvObject,   1, Array(OBJFORM, OBJDIALOG)) Then Goto Exit_Function
  68         If IsMissing(pvLeft) Then Call _TraceArguments()
  69         If IsMissing(pvTop) Then pvTop = -1
  70         If IsMissing(pvWidth) Then pvWidth = -1
  71         If IsMissing(pvHeight) Then pvHeight = -1
  72
  73         Move = pvObject.Move(pvLeft, pvTop, pvWidth, pvHeight)
  74
  75 Exit_Function:
  76         Utils._ResetCalledSub(&quot;Move&quot;)
  77         Exit Function
  78 Error_Function:
  79         TraceError(TRACEABORT, Err, &quot;Move&quot;, Erl)
  80         GoTo Exit_Function
  81 End Function            &apos;  Move    V.0.9.1
  82
  83 REM -----------------------------------------------------------------------------------------------------------------------
  84 Public Function OpenHelpFile()
  85 &apos;  Open the help file from the Help menu (IDE only)
  86 Const cstHelpFile = &quot;http://www.access2base.com/access2base.html&quot;
  87
  88         On Local Error Resume Next
  89         Call _ShellExecute(cstHelpFile)
  90
  91 End Function    &apos;  OpenHelpFile    V0.8.5
  92
  93 REM -----------------------------------------------------------------------------------------------------------------------
  94 Public Function Properties(Optional pvObject As Variant, ByVal Optional pvIndex As Variant) As Variant
  95 &apos;  Return
  96 &apos;          a Collection object if pvIndex absent
  97 &apos;          a Property object otherwise
  98
  99 Dim vProperties As Variant, oCounter As Variant, opProperty As Variant
 100 Dim vPropertiesList() As Variant
 101
 102         If IsMissing(pvObject) Or IsEmpty(pvObject) Then Call _TraceArguments()
 103         Utils._SetCalledSub(&quot;Properties&quot;)
 104
 105         Set vProperties = Nothing
 106         If Not Utils._CheckArgument(pvObject, 1, Array(OBJCOLLECTION, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJEVENT _
 107                                                 , OBJPROPERTY, OBJDATABASE, OBJQUERYDEF, OBJTABLEDEF, OBJRECORDSET _
 108                                                 )) Then Goto Exit_Function
 109
 110         If IsMissing(pvIndex) Then vProperties = pvObject.Properties Else vProperties = pvObject.Properties(pvIndex)
 111
 112 Exit_Function:
 113         Set Properties = vProperties
 114         Utils._ResetCalledSub(&quot;Properties&quot;)
 115         Exit Function
 116 End Function            &apos;  Properties      V0.9.0
 117
 118 REM -----------------------------------------------------------------------------------------------------------------------
 119 Public Function Refresh(Optional pvObject As Variant) As Boolean
 120 &apos;  Refresh data with its most recent value in the database in a form or subform
 121         Utils._SetCalledSub(&quot;Refresh&quot;)
 122         If IsMissing(pvObject) Then Call _TraceArguments()
 123         If _ErrorHandler() Then On Local Error Goto Error_Function
 124         Refresh = False
 125         If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJSUBFORM)) Then Goto Exit_Function
 126
 127         Refresh = pvObject.Refresh()
 128
 129 Exit_Function:
 130         Utils._ResetCalledSub(&quot;Refresh&quot;)
 131         Exit Function
 132 Error_Function:
 133         TraceError(TRACEABORT, Err, &quot;Refresh&quot;, Erl)
 134         GoTo Exit_Function
 135 End Function    &apos;  Refresh         V0.9.0
 136
 137 REM -----------------------------------------------------------------------------------------------------------------------
 138 Public Function RemoveItem(Optional pvBox As Variant,ByVal Optional pvIndex) As Boolean
 139 &apos;  Remove an item from a Listbox
 140 &apos;  Index may be a string value or an index-position
 141
 142         Utils._SetCalledSub(&quot;RemoveItem&quot;)
 143         If _ErrorHandler() Then On Local Error Goto Error_Function
 144
 145         If IsMissing(pvBox) Or IsMissing(pvIndex) Then Call _TraceArguments()
 146         If Not Utils._CheckArgument(pvBox, 1, Array(CTLLISTBOX, CTLCOMBOBOX)) Then Goto Exit_Function
 147
 148         RemoveItem = pvBox.RemoveItem(pvIndex)
 149
 150 Exit_Function:
 151         Utils._ResetCalledSub(&quot;RemoveItem&quot;)
 152         Exit Function
 153 Error_Function:
 154         TraceError(TRACEABORT, Err, &quot;RemoveItem&quot;, Erl)
 155         RemoveItem = False
 156         GoTo Exit_Function
 157 End Function            &apos;  RemoveItem              V0.9.0
 158
 159 REM -----------------------------------------------------------------------------------------------------------------------
 160 Public Function Requery(Optional pvObject As Variant) As Boolean
 161 &apos;  Refresh data displayed in a form, subform, combobox or listbox
 162         Utils._SetCalledSub(&quot;Requery&quot;)
 163         If IsMissing(pvObject) Then Call _TraceArguments()
 164         If _ErrorHandler() Then On Local Error Goto Error_Function
 165         If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL, OBJSUBFORM)) Then Goto Exit_Function
 166
 167         Requery = pvObject.Requery()
 168
 169 Exit_Function:
 170         Utils._ResetCalledSub(&quot;Requery&quot;)
 171         Exit Function
 172 Error_Function:
 173         TraceError(TRACEABORT, Err, &quot;Requery&quot;, Erl)
 174         GoTo Exit_Function
 175 End Function    &apos;  Requery         V0.9.0
 176
 177 REM -----------------------------------------------------------------------------------------------------------------------
 178 Public Function SetFocus(Optional pvObject As Variant) As Boolean
 179 &apos;  Execute SetFocus method
 180         Utils._SetCalledSub(&quot;setFocus&quot;)
 181         If IsMissing(pvObject) Then Call _TraceArguments()
 182         If _ErrorHandler() Then On Local Error Goto Error_Function
 183         If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL)) Then Goto Exit_Function
 184
 185         SetFocus = pvObject.setFocus()
 186
 187 Exit_Function:
 188         Utils._ResetCalledSub(&quot;SetFocus&quot;)
 189         Exit Function
 190 Error_Function:
 191         TraceError(TRACEABORT, Err, &quot;SetFocus&quot;, Erl)
 192         Goto Exit_Function
 193 Error_Grid:
 194         TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name))
 195         Goto Exit_Function
 196 End Function    &apos;  SetFocus        V0.9.0
 197
 198 REM -----------------------------------------------------------------------------------------------------------------------
 199 REM --- PRIVATE FUNCTIONS                                                                                                                                                                                       ---
 200 REM -----------------------------------------------------------------------------------------------------------------------
 201 Public Function _OptionGroup(ByVal pvGroupName As Variant _
 202                                         , ByVal psParentType As String _
 203                                         , poComponent As Object _
 204                                         , poParent As Object _
 205                                         ) As Variant
 206 &apos;  Return either an error or an object of type OPTIONGROUP based on its name
 207
 208         If IsMissing(pvGroupName) Then Call _TraceArguments()
 209         If _ErrorHandler() Then On Local Error Goto Error_Function
 210         Set _OptionGroup = Nothing
 211
 212         If Not Utils._CheckArgument(pvGroupName, 1, vbString) Then Goto Exit_Function
 213
 214 Dim ogGroup As Variant, i As Integer, j As Integer, bFound As Boolean
 215 Dim vOptionButtons() As Variant, sGroupName As String
 216 Dim lXY() As Long, iIndex() As Integer          &apos;  Two indexes X-Y coordinates
 217 Dim oView As Object, oDatabaseForm As Object, vControls As Variant
 218
 219 Const cstPixels = 10                                                    &apos;  Tolerance on coordinates when drawn approximately
 220
 221         bFound = False
 222         Select Case psParentType
 223                 Case CTLPARENTISFORM
 224                         &apos;poParent is a forms collection, find the appropriate database form
 225                         For i = 0 To poParent.Count - 1
 226                                 Set oDatabaseForm = poParent.getByIndex(i)
 227                                 If Not IsNull(oDatabaseForm) Then
 228                                         For j = 0 To oDatabaseForm.GroupCount - 1               &apos;  Does a group with the right name exist ?
 229                                                 oDatabaseForm.getGroup(j, vOptionButtons, sGroupName)
 230                                                 If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
 231                                                         bFound = True
 232                                                         Exit For
 233                                                 End If
 234                                         Next j
 235                                         If bFound Then Exit For
 236                                 End If
 237                                 If bFound Then Exit For
 238                         Next i
 239                 Case CTLPARENTISSUBFORM
 240                         &apos;poParent is already a database form
 241                         Set oDatabaseForm = poParent
 242                         For j = 0 To oDatabaseForm.GroupCount - 1               &apos;  Does a group with the right name exist ?
 243                                 oDatabaseForm.getGroup(j, vOptionButtons, sGroupName)
 244                                 If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then
 245                                         bFound = True
 246                                         Exit For
 247                                 End If
 248                         Next j
 249         End Select
 250
 251         If bFound Then
 252
 253                 ogGroup = New Optiongroup
 254                 ogGroup._This = ogGroup
 255                 ogGroup._Name = sGroupName
 256                 ogGroup._ButtonsGroup = vOptionButtons
 257                 ogGroup._Count = UBound(vOptionButtons) + 1
 258                 ogGroup._ParentType = psParentType
 259                 ogGroup._MainForm = oDatabaseForm.Name
 260                 Set ogGroup._ParentComponent = poComponent
 261
 262                 ReDim lXY(1, ogGroup._Count - 1)
 263                 ReDim iIndex(ogGroup._Count - 1)
 264                 For i = 0 To ogGroup._Count - 1                 &apos;  Find the position of each radiobutton
 265                         Set oView = poComponent.CurrentController.getControl(ogGroup._ButtonsGroup(i))
 266                         lXY(0, i) = oView.PosSize.X
 267                         lXY(1, i) = oView.PosSize.Y
 268                 Next i
 269                 For i = 0 To ogGroup._Count - 1                 &apos;  Sort them on XY coordinates
 270                         If i = 0 Then
 271                                 iIndex(0) = 0
 272                         Else
 273                                 iIndex(i) = i
 274                                 For j = i - 1 To 0 Step -1
 275                                         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
 276                                                 iIndex(i) = iIndex(j)
 277                                                 iIndex(j) = iIndex(j) + 1
 278                                         End If
 279                                 Next j
 280                         End If
 281                 Next i
 282                 ogGroup._ButtonsIndex = iIndex()
 283
 284                 Set _OptionGroup = ogGroup
 285
 286         Else
 287
 288                 Set _OptionGroup = Nothing
 289                 TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName))
 290
 291         End If
 292
 293 Exit_Function:
 294         Exit Function
 295 Error_Function:
 296         TraceError(TRACEABORT, Err,&quot;_OptionGroup&quot;, Erl)
 297         GoTo Exit_Function
 298 End Function            &apos;  _OptionGroup    V1.1.0
 299
 300 </script:module>