| blob | 27b0d74be34f95273f1e8f096d8f5c0c6dfffa11 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="DoCmd" 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 =======================================================================================================================
9 Option Explicit
11 Type _FindParams
13 FindWhat As Variant
14 Match As Integer
15 MatchCase As Boolean
16 Search As Integer
17 SearchAsFormatted As Boolean ' Must be False
18 FindFirst As Boolean
19 OnlyCurrentField As Integer
20 Form As String ' Shortcut
21 GridControl As String ' Shortcut
22 Target As String ' Shortcut
24 LastColumn As Integer ' Last column explored - 0 ... N-1 index in next arrays; 0 if OnlyCurrentField = acCurrent
25 ColumnNames() As String ' Array of column names in grid with boundfield and of same type as FindWhat
26 ResultSetIndex() As Integer ' Array of column numbers in ResultSet
27 End Type
29 Type _Window
30 Frame As Object ' com.sun.star.comp.framework.Frame
31 _Name As String ' Object Name
32 WindowType As Integer ' One of the object types
33 DocumentType As String ' Writer, Calc, ... - Only if WindowType = acDocument
34 End Type
36 REM VBA allows call to actions with missing arguments e.g. OpenForm("aaa",,"[field]=2")
37 REM in StarBasic IsMissing requires Variant parameters
39 REM -----------------------------------------------------------------------------------------------------------------------
40 Public Function ApplyFilter( _
41 ByVal Optional pvFilter As Variant _
42 , ByVal Optional pvSQL As Variant _
43 , ByVal Optional pvControlName As Variant _
44 ) As Boolean
45 ' Set filter on open table, query, form or subform (if pvControlName present)
47 If _ErrorHandler() Then On Local Error Goto Error_Function
49 Utils._SetCalledSub(cstThisSub)
50 ApplyFilter = False
52 If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments()
53 If IsMissing(pvFilter) Then pvFilter = ""
54 If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function
55 If IsMissing(pvSQL) Then pvSQL = ""
56 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
57 If IsMissing(pvControlName) Then pvControlName = ""
58 If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function
60 Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object
61 Set oDatabase = Application._CurrentDb()
62 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
64 If pvSQL <> "" _
65 Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _
66 Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter)
68 Set oWindow = _SelectWindow()
69 With oWindow
70 Select Case .WindowType
71 Case acForm
72 Set oTarget = _DatabaseForm(._Name, pvControlName)
73 Case acQuery, acTable
74 If pvControlName <> "" Then Goto Exit_Function
75 If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
77 Set oTarget = .Frame.Controller.FormOperations.Cursor
78 Case Else ' Ignore action
79 Goto Exit_Function
80 End Select
81 End With
83 With oTarget
84 .Filter = sFilter
85 .ApplyFilter = True
86 .reload()
87 End With
88 ApplyFilter = True
90 Exit_Function:
91 Utils._ResetCalledSub(cstThisSub)
92 Exit Function
93 Error_NotApplicable:
95 Goto Exit_Function
96 Error_Function:
97 TraceError(TRACEABORT, Err, cstThisSub, Erl)
98 GoTo Exit_Function
101 REM -----------------------------------------------------------------------------------------------------------------------
102 Public Function mClose(Optional ByVal pvObjectType As Variant _
103 , Optional ByVal pvObjectName As Variant _
104 , Optional ByVal pvSave As Variant _
105 ) As Boolean
106 If _ErrorHandler() Then On Local Error Goto Error_Function
109 Utils._SetCalledSub(cstThisSub)
110 mClose = False
111 If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments()
112 If IsMissing(pvSave) Then pvSave = acSavePrompt
113 If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
114 Array(acTable, acQuery, acForm, acReport)) _
115 And Utils._CheckArgument(pvObjectName, 2, vbString) _
116 And Utils._CheckArgument(pvSave, 3, Utils._AddNumeric(), Array(acSavePrompt)) _
117 ) Then Goto Exit_Function
119 Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object
120 Dim i As Integer, bFound As Boolean, lComponent As Long
121 Dim oDatabase As Object
122 Set oDatabase = Application._CurrentDb()
123 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
125 ' Check existence of object and find its exact (case-sensitive) name
126 Select Case pvObjectType
127 Case acForm
128 sObjects = Application._GetAllHierarchicalNames()
129 lComponent = com.sun.star.sdb.application.DatabaseObject.FORM
130 Case acTable
131 sObjects = oDatabase.Connection.getTables.ElementNames()
132 lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE
133 Case acQuery
134 sObjects = oDatabase.Connection.getQueries.ElementNames()
135 lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY
136 Case acReport
137 sObjects = oDatabase.Document.getReportDocuments.ElementNames()
138 lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT
139 End Select
140 bFound = False
141 For i = 0 To UBound(sObjects)
142 If UCase(pvObjectName) = UCase(sObjects(i)) Then
143 sObjectName = sObjects(i)
144 bFound = True
145 Exit For
146 End If
147 Next i
148 If Not bFound Then Goto Trace_NotFound
150 Select Case pvObjectType
151 Case acForm
152 Set oController = oDatabase.Document.getFormDocuments.getByHierarchicalName(sObjectName)
153 mClose = oController.close()
154 Case acTable, acQuery ' Not optimal but it works !!
155 Set oController = oDatabase.Document.CurrentController
156 Set oObject = oController.loadComponent(lComponent, sObjectName, False)
157 oObject.frame.close(False)
158 mClose = True
159 Case acReport
160 Set oController = oDatabase.Document.getReportDocuments.getByName(sObjectName)
161 mClose = oController.close()
162 End Select
165 Exit_Function:
166 Set oObject = Nothing
167 Set oController = Nothing
168 Utils._ResetCalledSub(cstThisSub)
169 Exit Function
170 Error_Function:
172 GoTo Exit_Function
173 Trace_Error:
174 TraceError(TRACEFATAL, ERRCLOSEOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName))
175 Goto Exit_Function
176 Trace_NotFound:
177 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName))
178 Goto Exit_Function
179 Error_NotApplicable:
181 Goto Exit_Function
184 REM -----------------------------------------------------------------------------------------------------------------------
185 Public Function CopyObject(ByVal Optional pvSourceDatabase As Variant _
186 , ByVal Optional pvNewName As Variant _
187 , ByVal Optional pvSourceType As Variant _
188 , ByVal Optional pvSourceName As Variant _
189 ) As Boolean
190 ' Copies tables and queries into identical (new) objects
191 If _ErrorHandler() Then On Local Error Goto Error_Function
193 Utils._SetCalledSub(cstThisSub)
194 CopyObject = False
196 If IsMissing(pvSourceDatabase) Then pvSourceDatabase = ""
197 If VarType(pvSourceDatabase) <> vbString Then
198 If Not Utils._CheckArgument(pvSourceDatabase, 1, OBJDATABASE) Then Goto Exit_Function
199 End If
200 If IsMissing(pvNewName) Then Call _TraceArguments()
201 If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function
202 If IsMissing(pvSourceType) Then Call _TraceArguments()
203 If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _
204 ) Then Goto Exit_Function
205 If IsMissing(pvSourceName) Then Call _TraceArguments()
206 If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto Exit_Function
208 Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase As Object, bSameDatabase As Boolean
209 Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object, oTargetCol As Object, iRDBMS As Integer
210 Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object
211 Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant
212 Dim vNameComponents() As Variant, iNames As Integer, sSurround As String
213 Dim vInputField As Variant, vFieldBinary() As Variant, vOutputField As Variant
214 Dim oInput as Object, oOutput As Object, iNbFields As Integer, vValue As Variant
215 Dim vBinary As Variant, lInputSize As Long, lOutputSize As Long
216 Dim lInputRecs As Long, lInputMax As Long, vField As Variant, bProgressMeter As Boolean, sFile As String
220 Const cstProgressMeterLimit = 100
222 Set oDatabase = Application._CurrentDb()
223 bSameDatabase = False
224 If VarType(pvSourceDatabase) = vbString Then
225 If pvSourceDatabase = "" Then
226 Set oSourceDatabase = oDatabase
227 bSameDatabase = True
228 Else
229 Set oSourceDatabase = Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), , , True)
230 If IsNull(oSourceDatabase) Then Goto Exit_Function
231 End If
232 Else
233 Set oSourceDatabase = pvSourceDatabase
234 End If
236 With oDatabase
237 iRDBMS = ._RDBMS
238 If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
239 Select Case pvSourceType
241 Case acQuery
242 Set oSource = oSourceDatabase.QueryDefs(pvSourceName, True)
243 If IsNull(oSource) Then Goto Error_NotFound
244 Set oTarget = .QueryDefs(pvNewName, True)
245 If Not IsNull(oTarget) Then .Connection.getQueries.dropByName(oTarget.Name) ' a query with same name exists already ... drop it
246 If oSource.Query.EscapeProcessing Then
247 Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL)
248 Else
249 Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough)
250 End If
251 ' Save .odb document
252 .Document.store()
254 Case acTable
255 Set oSource = oSourceDatabase.TableDefs(pvSourceName, True)
256 If IsNull(oSource) Then Goto Error_NotFound
257 Set oTarget = .TableDefs(pvNewName, True)
258 ' A table with same name exists already ... drop it
259 If Not IsNull(oTarget) Then .Connection.getTables.dropByName(oTarget.Name)
260 ' Copy source table columns
261 Set oSourceTable = oSource.Table
262 Set oTarget = .Connection.getTables.createDataDescriptor
263 oTarget.Description = oSourceTable.Description
265 iNames = UBound(vNameComponents)
266 If iNames >= 2 Then oTarget.CatalogName = vNameComponents(iNames - 2) Else oTarget.CatalogName = ""
267 If iNames >= 1 Then oTarget.SchemaName = vNameComponents(iNames - 1) Else oTarget.SchemaName = ""
268 oTarget.Name = vNameComponents(iNames)
269 oTarget.Type = oSourceTable.Type
270 Set oSourceColumns = oSourceTable.Columns
271 Set oTargetCol = oTarget.Columns.createDataDescriptor
273 ' Append each individual column to the table descriptor
274 Set oSourceCol = oSourceColumns.getByIndex(i)
275 _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase
276 oTarget.Columns.appendByDescriptor(oTargetCol)
277 Next i
279 ' Copy keys
280 Set oSourceKeys = oSourceTable.Keys
281 Set oTargetKey = oTarget.Keys.createDataDescriptor()
283 ' Append each key to table descriptor
284 Set oSourceKey = oSourceKeys.getByIndex(i)
285 oTargetKey.DeleteRule = oSourceKey.DeleteRule
286 oTargetKey.Name = oSourceKey.Name
287 oTargetKey.ReferencedTable = oSourceKey.ReferencedTable
288 oTargetKey.Type = oSourceKey.Type
289 oTargetKey.UpdateRule = oSourceKey.UpdateRule
290 Set oTargetCol = oTargetKey.Columns.createDataDescriptor()
292 Set oSourceCol = oSourceKey.Columns.getByIndex(j)
293 _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase, True
294 oTargetKey.Columns.appendByDescriptor(oTargetCol)
295 Next j
296 oTarget.Keys.appendByDescriptor(oTargetKey)
297 Next i
298 ' Duplicate table whole design
299 .Connection.getTables.appendByDescriptor(oTarget)
301 ' Copy data
302 Select Case bSameDatabase
303 Case True
304 ' Build SQL statement to copy data
305 sSurround = Utils._Surround(oSource.Name)
306 sSql = "INSERT INTO " & Utils._Surround(pvNewName) & " SELECT " & sSurround & ".* FROM " & sSurround
307 DoCmd.RunSQL(sSql)
308 Case False
309 ' Copy data row by row and field by field
310 ' As it is slow ... display a progress meter
311 Set oInput = oSourceDatabase.OpenRecordset(oSource.Name, , , dbReadOnly)
312 Set oOutput = .Openrecordset(pvNewName)
314 With oInput
315 If Not ( ._BOF And ._EOF ) Then
316 .MoveLast
317 lInputMax = .RecordCount
318 lInputRecs = 0
319 .MoveFirst
320 bProgressMeter = ( lInputMax > cstProgressMeterLimit )
322 iNbFields = .Fields().Count - 1
323 vFieldBinary = Array()
324 ReDim vFieldBinary(0 To iNbFields)
325 For i = 0 To iNbFields
326 vFieldBinary(i) = Utils._IsBinaryType(.Fields(i).Column.Type)
327 Next i
328 Else
329 bProgressMeter = False
330 End If
331 If bProgressMeter Then Application.SysCmd acSysCmdInitMeter, pvNewName & " 0 %", lInputMax
332 Do While Not .EOF()
333 oOutput.RowSet.moveToInsertRow()
334 oOutput._EditMode = dbEditAdd
335 For i = 0 To iNbFields
336 Set vInputField = .Fields(i)
337 Set vOutputField = oOutput.Fields(i)
338 If vFieldBinary(i) Then
339 lInputSize = vInputField.FieldSize
340 If lInputSize <= cstMaxBinlength Then
341 vField = Utils._getResultSetColumnValue(.RowSet, i + 1, True)
342 Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField)
343 ElseIf oDatabase._BinaryStream Then
344 ' Typically for SQLite where binary fields are limited
345 If lInputSize > vOutputField._Precision Then
346 TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1))
347 Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, Null)
348 Else
352 Kill ConvertToUrl(sFile)
353 End If
354 End If
355 Else
356 vField = Utils._getResultSetColumnValue(.RowSet, i + 1)
357 If VarType(vField) = vbString Then
358 If Len(vField) > vOutputField._Precision Then
359 TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1))
360 End If
361 End If
362 ' Update is done anyway, if too long, with truncation
363 Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField)
364 End If
365 Next i
367 If oOutput.RowSet.IsNew And oOutput.RowSet.IsModified Then oOutput.RowSet.insertRow()
368 oOutput._EditMode = dbEditNone
369 lInputRecs = lInputRecs + 1
370 If bProgressMeter Then
372 Application.SysCmd acSysCmdUpdateMeter, pvNewName & " " & CStr(CLng(lInputRecs * 100 / lInputMax)) & "%", lInputRecs
373 End If
374 End If
375 .MoveNext
376 Loop
377 End With
379 oOutput.mClose()
380 Set oOutput = Nothing
381 oInput.mClose()
382 Set oInput = Nothing
383 if bProgressMeter Then Application.SysCmd acSysCmdClearStatus
384 End Select
386 Case Else
387 End Select
388 End With
390 CopyObject = True
392 Exit_Function:
393 ' Avoid closing the current database or the database object given as source argument
394 If VarType(pvSourceDatabase) = vbString And Not bSameDatabase Then
395 If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose()
396 End If
397 Set oSourceDatabase = Nothing
398 If Not IsNull(oOutput) Then oOutput.mClose()
399 Set oOutput = Nothing
400 If Not IsNull(oInput) Then oInput.mClose()
401 Set oInput = Nothing
402 Set oSourceCol = Nothing
403 Set oSourceKey = Nothing
404 Set oSourceKeys = Nothing
405 Set oSource = Nothing
406 Set oSourceTable = Nothing
407 Set oSourceColumns = Nothing
408 Set oTargetCol = Nothing
409 Set oTargetKey = Nothing
410 Set oTarget = Nothing
411 Utils._ResetCalledSub(cstThisSub)
412 Exit Function
413 Error_NotFound:
414 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName))
415 Goto Exit_Function
416 Error_NotApplicable:
418 Goto Exit_Function
419 Error_Function:
420 TraceError(TRACEABORT, Err, cstThisSub, Erl)
421 GoTo Exit_Function
424 REM -----------------------------------------------------------------------------------------------------------------------
425 Public Function FindNext() As Boolean
426 ' Must be called after a FindRecord
427 ' Execute instructions set in FindRecord object
429 If _ErrorHandler() Then On Local Error Goto Error_Function
430 FindNext = False
433 Dim ofForm As Object, ocGrid As Object
434 Dim i As Integer, lInitialRow As Long, lFindRow As Long
435 Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean
436 Dim vFindValue As Variant, oFindrecord As Object
438 Set oFindRecord = _A2B_.FindRecord
439 If IsNull(oFindRecord) Then GoTo Error_FindRecord
440 With oFindRecord
442 If .FindRecord = 0 Then Goto Error_FindRecord
443 .FindRecord = 0
444 Set ofForm = getObject(.Form)
445 If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola
446 Set ocGrid = getObject(.GridControl)
448 ' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween
451 lInitialRow = .LastRow ' Used if Search = acSearchAll
453 bFound = False
454 lFindRow = .LastRow
455 b2ndRound = False
456 Do
457 ' Last column ? Go to next row
458 If .LastColumn >= UBound(.ColumnNames) Then
459 bStop = False
460 If ofForm.DatabaseForm.isAfterLast() And .Search = acUp Then
461 ofForm.DatabaseForm.last()
462 ElseIf ofForm.DatabaseForm.isLast() And .Search = acSearchAll Then
463 ofForm.DatabaseForm.first()
464 b2ndRound = True
465 ElseIf ofForm.DatabaseForm.isBeforeFirst() And (.Search = acDown Or .Search = acSearchAll) Then
466 ofForm.DatabaseForm.first()
467 ElseIf ofForm.DatabaseForm.isFirst() And .search = acUp Then
468 ofForm.DatabaseForm.beforeFirst()
469 bStop = True
470 ElseIf ofForm.DatabaseForm.isLast() And .search = acDown Then
471 ofForm.DatabaseForm.afterLast()
472 bStop = True
473 ElseIf .Search = acUp Then
474 ofForm.DatabaseForm.previous()
475 Else
476 ofForm.DatabaseForm.next()
477 End If
478 lFindRow = ofForm.DatabaseForm.getRow()
479 If bStop Or (.Search = acSearchAll And lFindRow >= lInitialRow And b2ndRound) Then
480 ofForm.DatabaseForm.absolute(lInitialRow)
481 Exit Do
482 End If
483 .LastColumn = 0
484 Else
485 .LastColumn = .LastColumn + 1
486 End If
488 ' Examine column contents
489 If .LastColumn <= UBound(.ColumnNames) Then
490 For i = .LastColumn To UBound(.ColumnNames)
491 vFindValue = Utils._getResultSetColumnValue(ofForm.DatabaseForm.createResultSet(), .ResultSetIndex(i))
492 Select Case VarType(.FindWhat)
493 Case vbDate, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
494 bFound = ( .FindWhat = vFindValue )
495 Case vbString
496 If VarType(vFindValue) = vbString Then
497 Select Case .Match
498 Case acStart
499 If .MatchCase Then
500 bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue )
501 Else
502 bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) )
503 End If
504 Case acAnyWhere
505 If .MatchCase Then
507 Else
509 End If
510 Case acEntire
511 If .MatchCase Then
512 bFound = ( .FindWhat = vFindValue )
513 Else
514 bFound = ( UCase(.FindWhat) = UCase(vFindValue) )
515 End If
516 End Select
517 Else
518 bFound = False
519 End If
520 End Select
521 If bFound Then
522 .LastColumn = i
523 Exit For
524 End If
525 Next i
526 End If
527 Loop While Not bFound
529 .LastRow = lFindRow
530 If bFound Then
531 ocGrid.Controls(.ColumnNames(.LastColumn)).setFocus()
532 .FindRecord = 1
533 FindNext = True
534 End If
536 End With
538 Exit_Function:
540 Exit Function
541 Error_Function:
543 GoTo Exit_Function
544 Error_FindRecord:
545 TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0)
546 Goto Exit_Function
549 REM -----------------------------------------------------------------------------------------------------------------------
550 Public Function FindRecord(Optional ByVal pvFindWhat As Variant _
551 , Optional ByVal pvMatch As Variant _
552 , Optional ByVal pvMatchCase As Variant _
553 , Optional ByVal pvSearch As Variant _
554 , Optional ByVal pvSearchAsFormatted As Variant _
555 , Optional ByVal pvTargetedField As Variant _
556 , Optional ByVal pvFindFirst As Variant _
557 ) As Boolean
559 'Find a value (string or other) in the underlying data of a gridcontrol
560 'Search in all columns or only in one single control
561 ' see pvTargetedField = acAll or acCurrent
562 ' pvTargetedField may also be a shortcut to a GridControl or one of its subcontrols
563 'Initialize _Findrecord structure in Database root and call FindNext() to set cursor on found value
565 If _ErrorHandler() Then On Local Error Goto Error_Function
566 FindRecord = False
569 If IsMissing(pvFindWhat) Or pvFindWhat = "" Then Call _TraceArguments()
570 If IsMissing(pvMatch) Then pvMatch = acEntire
571 If IsMissing(pvMatchCase) Then pvMatchCase = False
572 If IsMissing(pvSearch) Then pvSearch = acSearchAll
573 If IsMissing(pvSearchAsFormatted) Then pvSearchAsFormatted = False ' Anyway only False supported
574 If IsMissing(pvTargetedField) Then pvTargetedField = acCurrent
575 If IsMissing(pvFindFirst) Then pvFindFirst = True
576 If Not (Utils._CheckArgument(pvFindWhat, 1, Utils._AddNumeric(Array(vbString, vbDate))) _
577 And Utils._CheckArgument(pvMatch, 2, Utils._AddNumeric(), Array(acAnywhere, acEntire, acStart)) _
578 And Utils._CheckArgument(pvMatchCase, 3, vbBoolean) _
579 And Utils._CheckArgument(pvSearch, 4, Utils._AddNumeric(), Array(acDown, acSearchAll, acUp)) _
580 And Utils._CheckArgument(pvSearchAsFormatted, 5, vbBoolean, Array(False)) _
581 And Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(vbString)) _
582 And Utils._CheckArgument(pvFindFirst, 7, vbBoolean) _
583 ) Then Exit Function
584 If VarType(pvTargetedField) <> vbString Then
585 If Not Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(), Array(acAll, acCurrent)) Then Exit Function
586 End If
588 Dim ocTarget As Object, i As Integer, j As Integer, vNames() As Variant, iCount As Integer, vIndexes() As Variant
589 Dim vColumn As Variant, vDataField As Variant, ofParentForm As Variant, oColumns As Object, vParentGrid As Object
590 Dim bFound As Boolean, ocGridControl As Object, iFocus As Integer
591 Dim oFindRecord As _FindParams
592 With oFindRecord
593 .FindRecord = 0
594 .FindWhat = pvFindWhat
595 .Match = pvMatch
596 .MatchCase = pvMatchCase
597 .Search = pvSearch
598 .SearchAsFormatted = pvSearchAsFormatted
599 .FindFirst = pvFindFirst
601 ' Determine target
605 Select Case True
607 Case VarType(pvTargetedField) = vbString
608 Set ocTarget = getObject(pvTargetedField)
610 If ocTarget.SubType = CTLGRIDCONTROL Then
611 .OnlyCurrentField = acAll
612 .GridControl = ocTarget._Shortcut
613 .Target = .GridControl
614 ofParentForm = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name))
615 If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
616 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
617 iCount = -1
619 Set vColumn = ocTarget.ControlModel.getByIndex(i)
620 Set vDataField = vColumn.BoundField ' examine field type
621 If Not IsNull(vDataField) Then
622 If _CheckColumnType(pvFindWhat, vDataField) Then
623 iCount = iCount + 1
624 ReDim Preserve vNames(0 To iCount)
625 vNames(iCount) = vColumn.Name
626 ReDim Preserve vIndexes(0 To iCount)
628 If vDataField.Name = oColumns.ElementNames(j) Then
629 vIndexes(iCount) = j + 1
630 Exit For
631 End If
632 Next j
633 End If
634 End If
635 Next i
637 ElseIf ocTarget._Type = OBJCONTROL Then ' Control within a grid tbc
638 If IsNull(ocTarget.ControlModel.BoundField) Then Goto Error_Target ' Control MUST be bound to a database record or query
639 ' BoundField is in ControlModel, thanks PASTIM !
640 .OnlyCurrentField = acCurrent
641 vParentGrid = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name))
642 If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target
643 .GridControl = vParentGrid._Shortcut
644 ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name))
645 If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola
646 If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
647 .Target = ocTarget._Shortcut
648 Set vDataField = ocTarget.ControlModel.BoundField
649 If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target
651 vNames(0) = ocTarget._Name
652 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
654 If vDataField.Name = oColumns.ElementNames(j) Then
656 Exit For
657 End If
658 Next j
659 End If
661 Case Else ' Determine focus
662 iCount = Application.Forms()._Count
663 If iCount = 0 Then Goto Error_ActiveForm
664 bFound = False
666 Set ofParentForm = Application.Forms(i)
667 If ofParentForm.Component.CurrentController.Frame.IsActive() Then
668 bFound = True
669 Exit For
670 End If
671 Next i
672 If Not bFound Then Goto Error_ActiveForm
673 If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
674 iCount = ofParentForm.Controls().Count
675 bFound = False
677 Set ocGridControl = ofParentForm.Controls(i)
678 If ocGridControl.SubType = CTLGRIDCONTROL Then
679 bFound = True
680 Exit For
681 End If
682 Next i
683 If Not bFound Then Goto Error_NoGrid
684 .GridControl= ocGridControl._Shortcut
685 iFocus = -1
686 iFocus = ocGridControl.ControlView.getCurrentColumnPosition() ' Deprecated but no alternative found !!
688 If pvTargetedField = acAll Or iFocus < 0 Or iFocus >= ocGridControl.ControlModel.Count Then ' Has a control within the grid the focus ? NO
689 .OnlyCurrentField = acAll
690 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
691 iCount = -1
693 Set vColumn = ocGridControl.ControlModel.getByIndex(i)
694 Set vDataField = vColumn.BoundField ' examine field type
695 If Not IsNull(vDataField) Then
696 If _CheckColumnType(pvFindWhat, vDataField) Then
697 iCount = iCount + 1
698 ReDim Preserve vNames(0 To iCount)
699 vNames(iCount) = vColumn.Name
700 ReDim Preserve vIndexes(0 To iCount)
702 If vDataField.Name = oColumns.ElementNames(j) Then
703 vIndexes(iCount) = j + 1
704 Exit For
705 End If
706 Next j
707 End If
708 End If
709 Next i
711 Else ' Has a control within the grid the focus ? YES
712 .OnlyCurrentField = acCurrent
713 Set vColumn = ocGridControl.ControlModel.getByIndex(iFocus)
714 Set ocTarget = ocGridControl.Controls(vColumn.Name)
715 .Target = ocTarget._Shortcut
716 Set vDataField = ocTarget.ControlModel.BoundField
717 If IsNull(vDataField) Then Goto Error_Target ' Control MUST be bound to a database record or query
718 If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target
720 vNames(0) = ocTarget._Name
721 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
723 If vDataField.Name = oColumns.ElementNames(j) Then
725 Exit For
726 End If
727 Next j
728 End If
730 End Select
732 .Form = ofParentForm._Shortcut
733 .LastColumn = UBound(vNames)
734 .ColumnNames = vNames
735 .ResultSetIndex = vIndexes
736 If pvFindFirst Then
737 Select Case pvSearch
738 Case acDown, acSearchAll
739 ofParentForm.DatabaseForm.beforeFirst()
740 .LastRow = 0
741 Case acUp
742 ofParentForm.DatabaseForm.afterLast()
743 .LastRow = ofParentForm.DatabaseForm.RowCount + 1
744 End Select
745 Else
746 Select Case True
747 Case ofParentForm.DatabaseForm.isBeforeFirst And (pvSearch = acSearchAll Or pvSearch = acDown)
748 .LastRow = 0
749 Case ofParentForm.DatabaseForm.isAfterLast And pvSearch = acUp
750 ofParentForm.DatabaseForm.last() ' RowCount produces a wrong value as long as last record has not been reached
751 .LastRow = ofParentForm.DatabaseForm.RowCount + 1
752 Case Else
753 .LastRow = ofParentForm.DatabaseForm.getRow()
754 End Select
755 End If
757 .FindRecord = 1
759 End With
760 Set _A2B_.FindRecord = oFindRecord
761 FindRecord = DoCmd.Findnext()
763 Exit_Function:
765 Exit Function
766 Error_Function:
768 GoTo Exit_Function
769 Error_ActiveForm:
770 TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0)
771 Goto Exit_Function
772 Error_DatabaseForm:
774 Goto Exit_Function
775 Error_Target:
777 Goto Exit_Function
778 Error_NoGrid:
780 Goto Exit_Function
783 REM -----------------------------------------------------------------------------------------------------------------------
784 Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _
785 , ByVal Optional pvObjectName As Variant _
786 ) As Boolean
788 If _ErrorHandler() Then On Local Error Goto Error_Function
790 Utils._SetCalledSub(cstThisSub)
792 If IsMissing(pvObjectType) Then Call _TraceArguments()
793 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
794 Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _
795 ) Then Goto Exit_Function
796 If IsMissing(pvObjectName) Then
797 Select Case pvObjectType
798 Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
799 Case Else
800 End Select
801 pvObjectName = ""
802 Else
803 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
804 End If
806 Dim oWindow As Object
807 Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
808 If IsNull(oWindow.Frame) Then Goto Error_NotFound
809 GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible()
811 Exit_Function:
812 Utils._ResetCalledSub(cstThisSub)
813 Exit Function
814 Error_NotFound:
815 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
816 Goto Exit_Function
817 Error_Function:
818 TraceError(TRACEABORT, Err, cstThisSub, Erl)
819 GoTo Exit_Function
822 REM -----------------------------------------------------------------------------------------------------------------------
823 Public Function GoToControl(Optional ByVal pvControlName As variant) As Boolean
824 ' Set the focus on the named control on the active form.
825 ' Return False if the control does not exist or is disabled,
827 If _ErrorHandler() Then On Local Error Goto Error_Function
829 If IsMissing(pvControlName) Then Call _TraceArguments()
830 If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function
832 GoToControl = False
833 Dim oWindow As Object, ofForm As Object, ocControl As Object
834 Dim i As Integer, iCount As Integer
835 Set oWindow = _SelectWindow()
836 If oWindow.WindowType = acForm Then
837 Set ofForm = Application.Forms(oWindow._Name)
838 iCount = ofForm.Controls().Count
840 ocControl = ofForm.Controls(i)
841 If UCase(ocControl._Name) = UCase(pvControlName) Then
843 If ocControl.Enabled Then
844 ocControl.setFocus()
845 GoToControl = True
846 Exit For
847 End If
848 End If
849 End If
850 Next i
851 End If
853 Exit_Function:
855 Exit Function
856 Error_Function:
858 GoTo Exit_Function
861 REM -----------------------------------------------------------------------------------------------------------------------
862 Public Function GoToRecord(Optional ByVal pvObjectType As Variant _
863 , Optional ByVal pvObjectName As Variant _
864 , Optional ByVal pvRecord As Variant _
865 , Optional ByVal pvOffset As Variant _
866 ) As Boolean
868 'Move to record indicated by pvRecord/pvOffset in the window designated by pvObjectType and pvObjectName
870 If _ErrorHandler() Then On Local Error Goto Error_Function
871 GoToRecord = False
874 Utils._SetCalledSub(cstThisSub)
875 If IsMissing(pvObjectName) Then pvObjectName = ""
876 If IsMissing(pvObjectType) Then pvObjectType = acActiveDataObject
877 If IsMissing(pvRecord) Then pvRecord = acNext
878 If IsMissing(pvOffset) Then pvOffset = 1
879 If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _
880 , Array(acActiveDataObject, acDataForm, acDataQuery, acDataTable)) _
881 And Utils._CheckArgument(pvObjectName, 2, vbString) _
882 And Utils._CheckArgument(pvRecord, 3, Utils._AddNumeric() _
883 , Array(acFirst, acGoTo, acLast, acNewRec, acNext, acPrevious)) _
884 And Utils._CheckArgument(pvOffset, 4, Utils._AddNumeric()) _
885 ) Then Goto Exit_Function
886 If pvObjectType = acActiveDataObject And pvObjectName <> "" Then Goto Error_Target
889 Dim ofForm As Object, oGeneric As Object, oResultSet As Object, oWindow As Object
890 Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long
891 Dim sObjectName, iLengthName As Integer
892 Select Case pvObjectType
893 Case acActiveDataObject
894 Set oWindow = _SelectWindow()
895 With oWindow
896 Select Case .WindowType
897 Case acForm
898 Set oResultSet = _DatabaseForm(._Name, "")
899 Case acQuery, acTable
900 If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
902 Set oResultSet = .Frame.Controller.FormOperations.Cursor
903 Case Else ' Ignore action
904 Goto Exit_Function
905 End Select
906 End With
907 Case acDataForm
908 ' pvObjectName can be "myForm", "Forms!myForm", "Forms!myForm!mySubform" or "Forms!myForm!mySubform.Form"
909 sObjectName = UCase(pvObjectName)
910 iLengthName = Len(sObjectName)
911 Select Case True
912 Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" And Right(sObjectName, 5) = ".FORM"
913 Set ofForm = getObject(pvObjectName)
914 If ofForm._Type <> OBJSUBFORM Then Goto Error_Target
916 Set oGeneric = getObject(pvObjectName)
917 If oGeneric._Type = OBJFORM Or oGeneric._Type = OBJSUBFORM Then
918 Set ofForm = oGeneric
919 ElseIf oGeneric.SubType = CTLSUBFORM Then
920 Set ofForm = oGeneric.Form
921 Else Goto Error_Target
922 End If
923 Case sObjectName = ""
924 Call _TraceArguments()
925 Case Else
926 Set ofForm = Application.Forms(pvObjectName)
927 End Select
928 Set oResultSet = ofForm.DatabaseForm
929 Case acDataQuery
930 Set oWindow = _SelectWindow(acQuery, pvObjectName)
931 If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
933 Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor
934 Case acDataTable
935 Set oWindow = _SelectWindow(acTable, pvObjectName)
936 If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
937 Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor
938 Case Else
939 End Select
942 If oResultSet.IsNew Then
943 oResultSet.insertRow()
944 ElseIf oResultSet.IsModified Then
945 oResultSet.updateRow()
946 End If
948 lOffset = pvOffset
949 Select Case pvRecord
950 Case acFirst : GoToRecord = oResultSet.first()
951 Case acGoTo : GoToRecord = oResultSet.absolute(lOffset)
952 Case acLast : GoToRecord = oResultSet.last()
953 Case acNewRec
954 oResultSet.last() ' To simulate the behaviour in the UI
955 oResultSet.moveToInsertRow()
956 GoToRecord = True
957 Case acNext
958 If lOffset = 1 Then
959 GoToRecord = oResultSet.next()
960 Else
961 GoToRecord = oResultSet.relative(lOffset)
962 End If
963 Case acPrevious
964 If lOffset = 1 Then
965 GoToRecord = oResultSet.previous()
966 Else
967 GoToRecord = oResultSet.relative(- lOffset)
968 End If
969 End Select
971 Exit_Function:
972 Utils._ResetCalledSub(cstThisSub)
973 Exit Function
974 Error_Function:
975 TraceError(TRACEABORT, Err, cstThisSub, Erl)
976 GoTo Exit_Function
977 Error_Target:
979 Goto Exit_Function
980 Error_Offset:
982 Goto Exit_Function
983 Error_NotApplicable:
985 Goto Exit_Function
986 End Function ' GoToRecord
988 REM -----------------------------------------------------------------------------------------------------------------------
989 Public Function Maximize() As Boolean
990 ' Maximize the window having the focus
993 Dim oWindow As Object
994 Maximize = False
995 Set oWindow = _SelectWindow()
996 If Not IsNull(oWindow.Frame) Then
997 If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMaximized") Then oWindow.Frame.ContainerWindow.IsMaximized = True ' Ignored when <= OO3.2
998 Maximize = True
999 End If
1002 Exit Function
1005 REM -----------------------------------------------------------------------------------------------------------------------
1006 Public Function Minimize() As Boolean
1007 ' Maximize the form having the focus
1010 Dim oWindow As Object
1011 Minimize = False
1012 Set oWindow = _SelectWindow()
1013 If Not IsNull(oWindow.Frame) Then
1014 If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMinimized") Then oWindow.Frame.ContainerWindow.IsMinimized = True
1015 Minimize = True
1016 End If
1019 Exit Function
1022 REM -----------------------------------------------------------------------------------------------------------------------
1023 Public Function MoveSize(ByVal Optional pvLeft As Variant _
1024 , ByVal Optional pvTop As Variant _
1025 , ByVal Optional pvWidth As Variant _
1026 , ByVal Optional pvHeight As Variant _
1027 ) As Variant
1028 ' Execute MoveSize action
1029 If _ErrorHandler() Then On Local Error Goto Error_Function
1031 MoveSize = False
1032 If IsMissing(pvLeft) Then pvLeft = -1
1033 If IsMissing(pvTop) Then pvTop = -1
1034 If IsMissing(pvWidth) Then pvWidth = -1
1035 If IsMissing(pvHeight) Then pvHeight = -1
1036 If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function
1037 If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function
1038 If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function
1039 If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function
1041 Dim iArg As Integer, iWrong As Integer ' Check arguments values
1042 iArg = 0
1044 iArg = 4 : iWrong = pvHeight
1046 iArg = 3 : iWrong = pvWidth
1048 iArg = 2 : iWrong = pvTop
1050 iArg = 1 : iWrong = pvLeft
1051 End If
1054 Goto Exit_Function
1055 End If
1057 Dim iPosSize As Integer
1058 iPosSize = 0
1064 Dim oWindow As Object
1065 Set oWindow = _SelectWindow()
1066 With oWindow
1067 If Not IsNull(.Frame) Then
1068 If Utils._hasUNOProperty(.Frame.ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2
1069 .Frame.ContainerWindow.IsMaximized = False
1070 .Frame.ContainerWindow.IsMinimized = False
1071 End If
1072 .Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize)
1073 MoveSize = True
1074 End If
1075 End With
1077 Exit_Function:
1079 Exit Function
1080 Error_Function:
1082 GoTo Exit_Function
1085 REM -----------------------------------------------------------------------------------------------------------------------
1086 Public Function OpenForm(Optional ByVal pvFormName As Variant _
1087 , Optional ByVal pvView As Variant _
1088 , Optional ByVal pvFilterName As Variant _
1089 , Optional ByVal pvWhereCondition As Variant _
1090 , Optional ByVal pvDataMode As Variant _
1091 , Optional ByVal pvWindowMode As Variant _
1092 , Optional ByVal pvOpenArgs As Variant _
1093 ) As Variant
1095 If _ErrorHandler() Then On Local Error Goto Error_Function
1098 If IsMissing(pvFormName) Then Call _TraceArguments()
1099 If IsMissing(pvView) Then pvView = acNormal
1100 If IsMissing(pvFilterName) Then pvFilterName = ""
1101 If IsMissing(pvWhereCondition) Then pvWhereCondition = ""
1102 If IsMissing(pvDataMode) Then pvDataMode = acFormPropertySettings
1103 If IsMissing(pvWindowMode) Then pvWindowMode = acWindowNormal
1104 If IsMissing(pvOpenArgs) Then pvOpenArgs = ""
1105 Set OpenForm = Nothing
1106 If Not (Utils._CheckArgument(pvFormName, 1, vbString) _
1107 And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acNormal, acPreview, acDesign)) _
1108 And Utils._CheckArgument(pvFilterName, 3, vbString) _
1109 And Utils._CheckArgument(pvWhereCondition, 4, vbString) _
1110 And Utils._CheckArgument(pvDataMode, 5, Utils._AddNumeric(), Array(acFormAdd, acFormEdit, acFormPropertySettings, acFormReadOnly)) _
1111 And Utils._CheckArgument(pvWindowMode, 6, Utils._AddNumeric(), Array(acDialog, acHidden, acIcon, acWindowNormal)) _
1112 ) Then Goto Exit_Function
1114 Dim ofForm As Object, sWarning As String
1115 Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object
1117 Set oDatabase = Application._CurrentDb()
1118 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1120 Set ofForm = Application.AllForms(pvFormName)
1121 If ofForm.IsLoaded Then
1125 Set OpenForm = ofForm
1126 Goto Exit_Function
1127 End If
1128 ' Open the form
1129 Select Case pvView
1130 Case acNormal, acPreview: bOpenMode = False
1131 Case acDesign : bOpenMode = True
1132 End Select
1133 Set oController = oDatabase.Document.CurrentController
1134 Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode)
1136 ' Apply the filters (FilterName) AND (WhereCondition)
1137 Dim sFilter As String, oForm As Object, oFormsCollection As Object
1139 sFilter = ""
1141 sFilter = pvFilterName & pvWhereCondition
1142 Else
1143 sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")"
1144 End If
1145 Set oFormsCollection = oOpenForm.DrawPage.Forms
1146 If oFormsCollection.getCount() > 0 Then Set oForm = oFormsCollection.getByIndex(0) Else Set oForm = Nothing
1147 If Not IsNull(oForm) Then
1148 If sFilter <> "" Then
1149 oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter)
1150 oForm.ApplyFilter = True
1151 oForm.reload()
1152 ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed
1153 oForm.Filter = ""
1154 oForm.ApplyFilter = False
1155 oForm.reload()
1156 End If
1157 End If
1159 'Housekeeping
1160 Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open
1161 With ofForm
1162 If Not IsNull(.DatabaseForm) Then
1163 Select Case pvDataMode
1164 Case acFormAdd
1165 .AllowAdditions = True
1166 .AllowDeletions = False
1167 .AllowEdits = False
1168 Case acFormEdit
1169 .AllowAdditions = True
1170 .AllowDeletions = True
1171 .AllowEdits = True
1172 Case acFormReadOnly
1173 .AllowAdditions = False
1174 .AllowDeletions = False
1175 .AllowEdits = False
1176 Case acFormPropertySettings
1177 End Select
1178 End If
1179 .Visible = ( pvWindowMode <> acHidden )
1180 ._OpenArgs = pvOpenArgs
1181 'To avoid AOO 3.4 bug See http://user.services.openoffice.org/en/forum/viewtopic.php?f=13&t=53751
1182 .Component.CurrentController.ViewSettings.ShowOnlineLayout = True
1183 End With
1185 Set OpenForm = ofForm
1187 Exit_Function:
1189 Set ofForm = Nothing
1190 Set oOpenForm = Nothing
1191 Exit Function
1192 Error_Function:
1194 Set OpenForm = Nothing
1195 GoTo Exit_Function
1196 Error_NotApplicable:
1198 Goto Exit_Function
1199 Trace_Error:
1200 TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName)
1201 Set OpenForm = Nothing
1202 Goto Exit_Function
1205 REM -----------------------------------------------------------------------------------------------------------------------
1206 Public Function OpenQuery(Optional ByVal pvQueryName As Variant _
1207 , Optional ByVal pvView As Variant _
1208 , Optional ByVal pvDataMode As Variant _
1209 ) As Boolean
1211 If _ErrorHandler() Then On Local Error Goto Error_Function
1214 If IsMissing(pvQueryName) Then Call _TraceArguments()
1215 If IsMissing(pvView) Then pvView = acViewNormal
1216 If IsMissing(pvDataMode) Then pvDataMode = acEdit
1219 Exit_Function:
1221 Exit Function
1222 Error_Function:
1224 GoTo Exit_Function
1225 End Function ' OpenQuery
1227 REM -----------------------------------------------------------------------------------------------------------------------
1228 Public Function OpenReport(Optional ByVal pvReportName As Variant _
1229 , Optional ByVal pvView As Variant _
1230 , Optional ByVal pvDataMode As Variant _
1231 ) As Boolean
1233 If _ErrorHandler() Then On Local Error Goto Error_Function
1236 If IsMissing(pvReportName) Then Call _TraceArguments()
1237 If IsMissing(pvView) Then pvView = acViewNormal
1238 If IsMissing(pvDataMode) Then pvDataMode = acEdit
1241 Exit_Function:
1243 Exit Function
1244 Error_Function:
1246 GoTo Exit_Function
1247 End Function ' OpenReport
1249 REM -----------------------------------------------------------------------------------------------------------------------
1250 Public Function OpenSQL(Optional ByVal pvSQL As Variant _
1251 , Optional ByVal pvOption As Variant _
1252 ) As Boolean
1253 ' Return True if the execution of the SQL statement was successful
1254 ' SQL must contain a SELECT query
1255 ' pvOption can force pass through mode
1257 If _ErrorHandler() Then On Local Error Goto Error_Function
1261 OpenSQL = False
1262 If IsMissing(pvSQL) Then Call _TraceArguments()
1263 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
1264 Const cstNull = -1
1265 If IsMissing(pvOption) Then
1266 pvOption = cstNull
1267 Else
1268 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
1269 End If
1271 OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption)
1273 Exit_Function:
1275 Exit Function
1276 Error_Function:
1278 GoTo Exit_Function
1281 REM -----------------------------------------------------------------------------------------------------------------------
1282 Public Function OpenTable(Optional ByVal pvTableName As Variant _
1283 , Optional ByVal pvView As Variant _
1284 , Optional ByVal pvDataMode As Variant _
1285 ) As Boolean
1287 If _ErrorHandler() Then On Local Error Goto Error_Function
1290 If IsMissing(pvTableName) Then Call _TraceArguments()
1291 If IsMissing(pvView) Then pvView = acViewNormal
1292 If IsMissing(pvDataMode) Then pvDataMode = acEdit
1295 Exit_Function:
1297 Exit Function
1298 Error_Function:
1300 GoTo Exit_Function
1301 End Function ' OpenTable
1303 REM -----------------------------------------------------------------------------------------------------------------------
1304 Public Function OutputTo(ByVal pvObjectType As Variant _
1305 , ByVal Optional pvObjectName As Variant _
1306 , ByVal Optional pvOutputFormat As Variant _
1307 , ByVal Optional pvOutputFile As Variant _
1308 , ByVal Optional pvAutoStart As Variant _
1309 , ByVal Optional pvTemplateFile As Variant _
1310 , ByVal Optional pvEncoding As Variant _
1311 , ByVal Optional pvQuality As Variant _
1312 ) As Boolean
1313 REM https://wiki.openoffice.org/wiki/Framework/Article/Filter/FilterList_OOo_3_0
1314 REM https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options
1316 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms
1317 ' acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries
1319 If _ErrorHandler() Then On Local Error Goto Error_Function
1321 Utils._SetCalledSub(cstThisSub)
1323 OutputTo = False
1325 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputForm)) Then Goto Exit_Function
1326 If IsMissing(pvObjectName) Then pvObjectName = ""
1327 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
1328 If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
1329 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
1330 If pvOutputFormat <> "" Then
1331 If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
1332 UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _
1333 , UCase(acFormatODS), UCase(acFormatXLS), UCase(acFormatXLSX), UCase(acFormatTXT) _
1334 , "PDF", "ODT", "DOC", "HTML", "ODS", "XLS", "XLSX", "TXT", "CSV", "" _
1336 End If
1337 If IsMissing(pvOutputFile) Then pvOutputFile = ""
1338 If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
1339 If IsMissing(pvAutoStart) Then pvAutoStart = False
1340 If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
1341 If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
1342 If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function
1343 If IsMissing(pvEncoding) Then pvEncoding = 0
1344 If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function
1345 If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
1346 If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function
1348 If pvObjectType = acOutputTable Or pvObjectType = acOutputQuery Then
1349 OutputTo = Application._CurrentDb().OutputTo( _
1350 pvObjectType _
1351 , pvObjectName _
1352 , pvOutputFormat _
1353 , pvOutputFile _
1354 , pvAutoStart _
1355 , pvTemplateFile _
1356 , pvEncoding _
1357 , pvQuality _
1358 )
1359 GoTo Exit_Function
1360 End If
1362 Dim vWindow As Variant, sOutputFile As String, ofForm As Object, i As Integer, bFound As Boolean
1363 'Find applicable form
1364 If pvObjectName = "" Then
1365 vWindow = _SelectWindow()
1366 If vWindow.WindowType <> acOutoutForm Then Goto Error_Action
1367 Set ofForm = Application.Forms(vWindow._Name)
1368 Else
1369 bFound = False
1371 Set ofForm = Application.Forms(i)
1372 If UCase(ofForm._Name) = UCase(pvObjectName) Then
1373 bFound = True
1374 Exit For
1375 End If
1376 Next i
1377 If Not bFound Then Goto Error_NotFound
1378 End If
1380 'Determine format and parameters
1381 Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport As Object, sSuffix As String
1382 If pvOutputFormat = "" Then
1383 sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format
1384 If sOutputFormat = "" Then Goto Exit_Function
1385 Else
1386 sOutputFormat = UCase(pvOutputFormat)
1387 End If
1388 Select Case sOutputFormat
1390 sFilter = acFormatPDF
1391 oFilterData = Array( _
1393 )
1396 sFilter = acFormatDOC
1397 oFilterData = Array()
1400 sFilter = acFormatODT
1401 oFilterData = Array()
1404 sFilter = acFormatHTML
1405 oFilterData = Array()
1407 End Select
1408 oExport = Array( _
1412 )
1414 'Determine output file
1416 sOutputFile = _PromptFilePicker(sSuffix)
1417 If sOutputFile = "" Then Goto Exit_Function
1418 Else
1419 sOutputFile = pvOutputFile
1420 End If
1421 sOutputFile = ConvertToURL(sOutputFile)
1423 'Create file
1424 On Local Error Goto Error_File
1425 ofForm.Component.storeToURL(sOutputFile, oExport)
1426 On Local Error Goto Error_Function
1428 'Launch application, if requested
1429 If pvAutoStart Then Call _ShellExecute(sOutputFile)
1431 OutputTo = True
1433 Exit_Function:
1434 Utils._ResetCalledSub(cstThisSub)
1435 Exit Function
1436 Error_NotFound:
1437 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1438 Goto Exit_Function
1439 Error_Action:
1440 TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
1441 Goto Exit_Function
1442 Error_Function:
1443 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1444 GoTo Exit_Function
1445 Error_File:
1446 TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
1447 GoTo Exit_Function
1450 REM -----------------------------------------------------------------------------------------------------------------------
1451 Public Function Quit(Optional ByVal pvSave As Variant) As Variant
1452 ' Quit the application
1455 If _ErrorHandler() Then On Local Error Goto Error_Function
1457 Utils._SetCalledSub(cstThisSub)
1459 If IsMissing(pvSave) Then pvSave = acQuitSaveAll
1460 If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _
1461 Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _
1462 ) Then Goto Exit_Function
1464 Dim oDatabase As Object, oDoc As Object
1465 Set oDatabase = Application._CurrentDb()
1466 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1467 If Not IsNull(oDatabase) Then
1468 Set oDoc = oDatabase.Document
1469 Select Case pvSave
1470 Case acQuitPrompt
1471 If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function
1472 Case acQuitSaveNone
1473 oDoc.setModified(False)
1474 Case Else
1475 End Select
1477 If (oDoc.isModified) Then
1478 If (oDoc.hasLocation AND (Not oDoc.isReadOnly)) Then
1479 oDoc.store()
1480 End If
1481 End If
1482 oDoc.close(true)
1483 Else
1484 oDoc.dispose()
1485 End If
1486 End If
1488 Exit_Function:
1489 Utils._ResetCalledSub(cstThisSub)
1490 Set oDatabase = Nothing
1491 Set oDoc = Nothing
1492 Exit Function
1493 Error_Function:
1494 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
1495 Set OpenForm = Nothing
1496 GoTo Exit_Function
1497 Error_NotApplicable:
1499 Goto Exit_Function
1502 REM -----------------------------------------------------------------------------------------------------------------------
1503 Public Sub RunApp(Optional ByVal pvCommandLine As Variant)
1504 ' Convert to URL and execute the Command Line
1506 If _ErrorHandler() Then On Local Error Goto Error_Sub
1510 If IsMissing(pvCommandLine) Then Call _TraceArguments()
1511 If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub
1513 _ShellExecute(ConvertToURL(pvCommandLine))
1515 Exit_Sub:
1517 Exit Sub
1518 Error_Sub:
1520 GoTo Exit_Sub
1523 REM -----------------------------------------------------------------------------------------------------------------------
1524 Public Function RunCommand(Optional pvCommand As Variant, Optional pbReturnCommand As Boolean) As Variant
1525 ' Execute command via DispatchHelper
1526 ' pbReturnCommand = internal parameter to only return the exact command string (always absent if uno prefix present in pvCommand)
1528 If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort
1530 Utils._SetCalledSub(cstThisSub)
1532 Dim iVBACommand As Integer, sOOCommand As String, sDispatch As String
1533 If IsMissing(pvCommand) Then Call _TraceArguments()
1534 If Not ( Utils._CheckArgument(pvCommand, 1, Utils._AddNumeric(vbString)) ) Then Goto Exit_Function
1535 If IsMissing(pbReturnCommand) Then pbReturnCommand = False
1537 RunCommand = True
1540 If VarType(pvCommand) = vbString Then
1541 sOOCommand = pvCommand
1542 iVBACommand = -1
1543 If _IsLeft(sOOCommand, cstUnoPrefix) Then
1544 Call _DispatchCommand(sOOCommand)
1545 Goto Exit_Function
1546 End If
1547 Else
1548 sOOCommand = ""
1549 iVBACommand = pvCommand
1550 End If
1552 Select Case True
1553 Case iVBACommand = acCmdAboutMicrosoftAccess Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
1554 Case iVBACommand = acCmdAboutOpenOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
1555 Case iVBACommand = acCmdAboutLibreOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
1559 Case UCase(sOOCommand) = "AUTOCONTROLFOCUS" : sDispatch = "AutoControlFocus"
1561 Case UCase(sOOCommand) = "AUTOPILOTADDRESSDATASOURCE" : sDispatch = "AutoPilotAddressDataSource"
1563 Case iVBACommand = acCmdVisualBasicEditor Or UCase(sOOCommand) = "BASICIDEAPPEAR" : sDispatch = "BasicIDEAppear"
1565 Case iVBACommand = acCmdBringToFront Or UCase(sOOCommand) = "BRINGTOFRONT" : sDispatch = "BringToFront"
1568 Case iVBACommand = acCmdClose Or UCase(sOOCommand) = "CLOSEDOC" : sDispatch = "CloseDoc"
1570 Case iVBACommand = acCmdToolbarsCustomize Or UCase(sOOCommand) = "CONFIGUREDIALOG" : sDispatch = "ConfigureDialog"
1571 Case UCase(sOOCommand) = "CONTROLPROPERTIES" : sDispatch = "ControlProperties"
1572 Case iVBACommand = acCmdChangeToCommandButton Or UCase(sOOCommand) = "CONVERTTOBUTTON" : sDispatch = "ConvertToButton"
1573 Case iVBACommand = acCmdChangeToCheckBox Or UCase(sOOCommand) = "CONVERTTOCHECKBOX" : sDispatch = "ConvertToCheckBox"
1574 Case iVBACommand = acCmdChangeToComboBox Or UCase(sOOCommand) = "CONVERTTOCOMBO" : sDispatch = "ConvertToCombo"
1575 Case UCase(sOOCommand) = "CONVERTTOCURRENCY" : sDispatch = "ConvertToCurrency"
1577 Case iVBACommand = acCmdChangeToTextBox Or UCase(sOOCommand) = "CONVERTTOEDIT" : sDispatch = "ConvertToEdit"
1578 Case UCase(sOOCommand) = "CONVERTTOFILECONTROL" : sDispatch = "ConvertToFileControl"
1579 Case iVBACommand = acCmdChangeToLabel Or UCase(sOOCommand) = "CONVERTTOFIXED" : sDispatch = "ConvertToFixed"
1580 Case UCase(sOOCommand) = "CONVERTTOFORMATTED" : sDispatch = "ConvertToFormatted"
1582 Case UCase(sOOCommand) = "CONVERTTOIMAGEBTN" : sDispatch = "ConvertToImageBtn"
1583 Case iVBACommand = acCmdChangeToImage Or UCase(sOOCommand) = "CONVERTTOIMAGECONTROL" : sDispatch = "ConvertToImageControl"
1584 Case iVBACommand = acCmdChangeToListBox Or UCase(sOOCommand) = "CONVERTTOLIST" : sDispatch = "ConvertToList"
1585 Case UCase(sOOCommand) = "CONVERTTONAVIGATIONBAR" : sDispatch = "ConvertToNavigationBar"
1586 Case UCase(sOOCommand) = "CONVERTTONUMERIC" : sDispatch = "ConvertToNumeric"
1587 Case UCase(sOOCommand) = "CONVERTTOPATTERN" : sDispatch = "ConvertToPattern"
1588 Case iVBACommand = acCmdChangeToOptionButton Or UCase(sOOCommand) = "CONVERTTORADIO" : sDispatch = "ConvertToRadio"
1589 Case UCase(sOOCommand) = "CONVERTTOSCROLLBAR" : sDispatch = "ConvertToScrollBar"
1590 Case UCase(sOOCommand) = "CONVERTTOSPINBUTTON" : sDispatch = "ConvertToSpinButton"
1592 Case iVBACommand = acCmdCopy Or UCase(sOOCommand) = "COPY" : sDispatch = "Copy"
1594 Case iVBACommand = acCmdCut Or UCase(sOOCommand) = "CUT" : sDispatch = "Cut"
1596 Case iVBACommand = acCmdCreateRelationship Or UCase(sOOCommand) = "DBADDRELATION " : sDispatch = "DBAddRelation "
1597 Case UCase(sOOCommand) = "DBCONVERTTOVIEW " : sDispatch = "DBConvertToView "
1598 Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DBDELETE " : sDispatch = "DBDelete "
1600 Case UCase(sOOCommand) = "DBDSADVANCEDSETTINGS " : sDispatch = "DBDSAdvancedSettings "
1601 Case UCase(sOOCommand) = "DBDSCONNECTIONTYPE " : sDispatch = "DBDSConnectionType "
1602 Case iVBACommand = acCmdDatabaseProperties Or UCase(sOOCommand) = "DBDSPROPERTIES " : sDispatch = "DBDSProperties "
1604 Case iVBACommand = acCmdSQLView Or UCase(sOOCommand) = "DBEDITSQLVIEW " : sDispatch = "DBEditSqlView "
1605 Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBFORMDELETE " : sDispatch = "DBFormDelete "
1606 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBFORMEDIT " : sDispatch = "DBFormEdit "
1607 Case iVBACommand = acCmdFormView Or UCase(sOOCommand) = "DBFORMOPEN " : sDispatch = "DBFormOpen "
1609 Case iVBACommand = acCmdNewObjectForm Or UCase(sOOCommand) = "DBNEWFORM " : sDispatch = "DBNewForm "
1610 Case UCase(sOOCommand) = "DBNEWFORMAUTOPILOT " : sDispatch = "DBNewFormAutoPilot "
1612 Case UCase(sOOCommand) = "DBNEWQUERYAUTOPILOT " : sDispatch = "DBNewQueryAutoPilot "
1615 Case UCase(sOOCommand) = "DBNEWREPORTAUTOPILOT " : sDispatch = "DBNewReportAutoPilot "
1616 Case iVBACommand = acCmdNewObjectTable Or UCase(sOOCommand) = "DBNEWTABLE " : sDispatch = "DBNewTable "
1617 Case UCase(sOOCommand) = "DBNEWTABLEAUTOPILOT " : sDispatch = "DBNewTableAutoPilot "
1618 Case iVBACommand = acCmdNewObjectView Or UCase(sOOCommand) = "DBNEWVIEW " : sDispatch = "DBNewView "
1620 Case iVBACommand = acCmdOpenDatabase Or UCase(sOOCommand) = "DBOPEN " : sDispatch = "DBOpen "
1621 Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBQUERYDELETE " : sDispatch = "DBQueryDelete "
1622 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBQUERYEDIT " : sDispatch = "DBQueryEdit "
1623 Case iVBACommand = acCmdNewObjectQuery Or UCase(sOOCommand) = "DBQUERYOPEN " : sDispatch = "DBQueryOpen "
1625 Case UCase(sOOCommand) = "DBREFRESHTABLES " : sDispatch = "DBRefreshTables "
1626 Case iVBACommand = acCmdShowAllRelationships Or UCase(sOOCommand) = "DBRELATIONDESIGN " : sDispatch = "DBRelationDesign "
1628 Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBREPORTDELETE " : sDispatch = "DBReportDelete "
1629 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBREPORTEDIT " : sDispatch = "DBReportEdit "
1630 Case iVBACommand = acCmdNewObjectReport Or UCase(sOOCommand) = "DBREPORTOPEN " : sDispatch = "DBReportOpen "
1632 Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "DBSELECTALL " : sDispatch = "DBSelectAll "
1633 Case UCase(sOOCommand) = "DBSHOWDOCINFOPREVIEW " : sDispatch = "DBShowDocInfoPreview "
1634 Case UCase(sOOCommand) = "DBSHOWDOCPREVIEW " : sDispatch = "DBShowDocPreview "
1635 Case iVBACommand = acCmdRemoveTable Or UCase(sOOCommand) = "DBTABLEDELETE " : sDispatch = "DBTableDelete "
1636 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBTABLEEDIT " : sDispatch = "DBTableEdit "
1638 Case iVBACommand = acCmdOpenTable Or UCase(sOOCommand) = "DBTABLEOPEN " : sDispatch = "DBTableOpen "
1639 Case iVBACommand = acCmdRename Or UCase(sOOCommand) = "DBTABLERENAME " : sDispatch = "DBTableRename "
1645 Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DELETE" : sDispatch = "Delete"
1646 Case iVBACommand = acCmdDeleteRecord Or UCase(sOOCommand) = "DELETERECORD" : sDispatch = "DeleteRecord"
1654 Case iVBACommand = acCmdApplyFilterSort Or UCase(sOOCommand) = "FORMFILTERED" : sDispatch = "FormFiltered"
1655 Case UCase(sOOCommand) = "FORMFILTEREXECUTE" : sDispatch = "FormFilterExecute"
1657 Case UCase(sOOCommand) = "FORMFILTERNAVIGATOR" : sDispatch = "FormFilterNavigator"
1662 Case iVBACommand = acCmdSnapToGrid Or UCase(sOOCommand) = "GRIDUSE" : sDispatch = "GridUse"
1663 Case iVBACommand = acCmdViewGrid Or UCase(sOOCommand) = "GRIDVISIBLE" : sDispatch = "GridVisible"
1667 Case iVBACommand = acCmdInsertHyperlink Or UCase(sOOCommand) = "HYPERLINKDIALOG" : sDispatch = "HyperlinkDialog"
1671 Case iVBACommand = acCmdMaximumRecords Or UCase(sOOCommand) = "LASTRECORD" : sDispatch = "LastRecord"
1676 Case iVBACommand = acCmdObjectBrowser Or UCase(sOOCommand) = "NAVIGATOR" : sDispatch = "Navigator"
1682 Case UCase(sOOCommand) = "OPTIONSTREEDIALOG" : sDispatch = "OptionsTreeDialog"
1685 Case iVBACommand = acCmdPaste Or UCase(sOOCommand) = "PASTE" : sDispatch = "Paste"
1686 Case iVBACommand = acCmdPasteSpecial Or UCase(sOOCommand) = "PASTESPECIAL " : sDispatch = "PasteSpecial "
1689 Case iVBACommand = acCmdPrint Or UCase(sOOCommand) = "PRINT" : sDispatch = "Print"
1692 Case iVBACommand = acCmdPrintPreview Or UCase(sOOCommand) = "PRINTPREVIEW" : sDispatch = "PrintPreview"
1696 Case iVBACommand = acCmdSaveRecord Or UCase(sOOCommand) = "RECSAVE" : sDispatch = "RecSave"
1697 Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "RECSEARCH" : sDispatch = "RecSearch"
1698 Case iVBACommand = acCmdUndo Or UCase(sOOCommand) = "RECUNDO" : sDispatch = "RecUndo"
1699 Case iVBACommand = acCmdRefresh Or UCase(sOOCommand) = "REFRESH" : sDispatch = "Refresh"
1701 Case iVBACommand = acCmdRemoveFilterSort Or UCase(sOOCommand) = "REMOVEFILTERSORT" : sDispatch = "RemoveFilterSort"
1702 Case iVBACommand = acCmdRunMacro Or UCase(sOOCommand) = "RUNMACRO" : sDispatch = "RunMacro"
1703 Case iVBACommand = acCmdSave Or UCase(sOOCommand) = "SAVE" : sDispatch = "Save"
1705 Case iVBACommand = acCmdSaveAs Or UCase(sOOCommand) = "SAVEAS" : sDispatch = "SaveAs"
1709 Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "SEARCHDIALOG" : sDispatch = "SearchDialog"
1710 Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll"
1711 Case iVBACommand = acCmdSelectAllRecords Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll"
1712 Case iVBACommand = acCmdSendToBack Or UCase(sOOCommand) = "SENDTOBACK" : sDispatch = "SendToBack"
1715 Case iVBACommand = acCmdSortDescending Or UCase(sOOCommand) = "SORTDOWN" : sDispatch = "SortDown"
1716 Case iVBACommand = acCmdSortAscending Or UCase(sOOCommand) = "SORTUP" : sDispatch = "Sortup"
1718 Case UCase(sOOCommand) = "STATUSBARVISIBLE" : sDispatch = "StatusBarVisible"
1719 Case UCase(sOOCommand) = "SWITCHCONTROLDESIGNMODE" : sDispatch = "SwitchControlDesignMode"
1720 Case iVBACommand = acCmdTabOrder Or UCase(sOOCommand) = "TABDIALOG" : sDispatch = "TabDialog"
1723 Case UCase(sOOCommand) = "VIEWDATASOURCEBROWSER" : sDispatch = "ViewDataSourceBrowser"
1724 Case iVBACommand = acCmdDatasheetView Or UCase(sOOCommand) = "VIEWFORMASGRID" : sDispatch = "ViewFormAsGrid"
1725 Case iVBACommand = acCmdZoomSelection Or UCase(sOOCommand) = "ZOOM" : sDispatch = "Zoom"
1726 Case Else
1728 sDispatch = pvCommand
1729 End Select
1731 If pbReturnCommand Then RunCommand = cstUnoPrefix & sDispatch Else Call _DispatchCommand(cstUnoPrefix & sDispatch)
1733 Exit_Function:
1734 Utils._ResetCalledSub(cstThisSub)
1735 Exit Function
1736 Error_Function:
1737 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
1738 GoTo Exit_Function
1741 REM -----------------------------------------------------------------------------------------------------------------------
1742 Public Function RunSQL(Optional ByVal pvSQL As Variant _
1743 , Optional ByVal pvOption As Variant _
1744 ) As Boolean
1745 ' Return True if the execution of the SQL statement was successful
1746 ' SQL must contain an ACTION query
1748 If _ErrorHandler() Then On Local Error Goto Error_Function
1752 RunSQL = False
1753 If IsMissing(pvSQL) Then Call _TraceArguments()
1754 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
1755 Const cstNull = -1
1756 If IsMissing(pvOption) Then
1757 pvOption = cstNull
1758 Else
1759 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
1760 End If
1762 RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption)
1764 Exit_Function:
1766 Exit Function
1767 Error_Function:
1769 GoTo Exit_Function
1772 REM -----------------------------------------------------------------------------------------------------------------------
1773 Public Function SelectObject( ByVal Optional pvObjectType As Variant _
1774 , ByVal Optional pvObjectName As Variant _
1775 , ByVal Optional pvInDatabaseWindow As Variant _
1776 ) As Boolean
1778 If _ErrorHandler() Then On Local Error Goto Error_Function
1780 Utils._SetCalledSub(cstThisSub)
1782 If IsMissing(pvObjectType) Then Call _TraceArguments()
1783 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
1784 Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _
1785 ) Then Goto Exit_Function
1786 If IsMissing(pvObjectName) Then
1787 Select Case pvObjectType
1788 Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
1789 Case Else
1790 End Select
1791 pvObjectName = ""
1792 Else
1793 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
1794 End If
1795 If Not IsMissing(pvInDatabaseWindow) Then
1796 If Not Utils._CheckArgument(pvInDatabaseWindow, 3, vbBoolean, False) Then Goto Exit_Function
1797 End If
1799 Dim oWindow As Object
1800 Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
1801 If IsNull(oWindow.Frame) Then Goto Error_NotFound
1802 With oWindow.Frame.ContainerWindow
1803 If .isVisible() = False Then .setVisible(True)
1804 .IsMinimized = False
1805 .setFocus()
1806 .setEnable(True) ' Added to try to bypass desynchro issue in Linux
1807 .toFront() ' Added to force window change in Linux
1808 End With
1810 Exit_Function:
1811 Utils._ResetCalledSub(cstThisSub)
1812 Exit Function
1813 Error_NotFound:
1814 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1815 Goto Exit_Function
1816 Error_Function:
1817 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1818 GoTo Exit_Function
1821 REM -----------------------------------------------------------------------------------------------------------------------
1822 Public Function SendObject(ByVal Optional pvObjectType As Variant _
1823 , ByVal Optional pvObjectName As Variant _
1824 , ByVal Optional pvOutputFormat As Variant _
1825 , ByVal Optional pvTo As Variant _
1826 , ByVal Optional pvCc As Variant _
1827 , ByVal Optional pvBcc As Variant _
1828 , ByVal Optional pvSubject As Variant _
1829 , ByVal Optional pvMessageText As Variant _
1830 , ByVal Optional pvEditMessage As Variant _
1831 , ByVal Optional pvTemplateFile As Variant _
1832 ) As Boolean
1833 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms
1834 'To be prepared: acFormatCSV and acFormatODS for tables/queries ?
1835 If _ErrorHandler() Then On Local Error Goto Error_Function
1837 SendObject = False
1839 If IsMissing(pvObjectType) Then pvObjectType = acSendNoObject
1840 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acSendNoObject, acSendForm)) Then Goto Exit_Function
1841 If IsMissing(pvObjectName) Then pvObjectName = ""
1842 If Not Utils._CheckArgument(pvObjectName, 2,vbString) Then Goto Exit_Function
1843 If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
1844 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
1845 If pvOutputFormat <> "" Then
1846 If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
1847 UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _
1850 End If
1851 If IsMissing(pvTo) Then pvTo = ""
1852 If Not Utils._CheckArgument(pvTo, 4, vbString) Then Goto Exit_Function
1853 If IsMissing(pvCc) Then pvCc = ""
1854 If Not Utils._CheckArgument(pvCc, 5, vbString) Then Goto Exit_Function
1855 If IsMissing(pvBcc) Then pvBcc = ""
1856 If Not Utils._CheckArgument(pvBcc, 6, vbString) Then Goto Exit_Function
1857 If IsMissing(pvSubject) Then pvSubject = ""
1858 If Not Utils._CheckArgument(pvSubject, 7, vbString) Then Goto Exit_Function
1859 If IsMissing(pvMessageText) Then pvMessageText = ""
1860 If Not Utils._CheckArgument(pvMessageText, 8, vbString) Then Goto Exit_Function
1861 If IsMissing(pvEditMessage) Then pvEditMessage = True
1862 If Not Utils._CheckArgument(pvEditMessage, 9, vbBoolean) Then Goto Exit_Function
1863 If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
1866 Dim vTo() As Variant, vCc() As Variant, vBcc() As Variant, oWindow As Object
1867 Dim sDirectory As String, sOutputFile As String, sSuffix As String, sOutputFormat As String
1869 If pvTo <> "" Then vTo() = Split(pvTo, cstSemiColon) Else vTo() = Array()
1870 If pvCc <> "" Then vCc() = Split(pvCc, cstSemiColon) Else vCc() = Array()
1871 If pvBcc <> "" Then vBcc() = Split(pvBcc, cstSemiColon) Else vBcc() = Array()
1872 Select Case True
1873 Case pvObjectType = acSendNoObject And pvObjectName = ""
1874 SendObject = _SendWithoutAttachment(vTo, vCc, vBcc, pvSubject, pvMessageText)
1875 Case Else
1876 If pvObjectType = acSendNoObject And pvObjectName <> "" Then
1877 If Not FileExists(pvObjectName) Then Goto Error_File
1878 sOutputFile = pvObjectName
1879 Else ' OutputFile has to be created
1881 oWindow = _SelectWindow()
1882 If oWindow.WindowType <> acSendForm Then Goto Error_Action
1883 pvObjectType = acSendForm
1884 pvObjectName = oWindow._Name
1885 End If
1886 sDirectory = Utils._getTempDirectoryURL()
1887 If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/"
1888 If pvOutputFormat = "" Then
1889 sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format
1890 If sOutputFormat = "" Then Goto Exit_Function
1891 Else
1892 sOutputFormat = UCase(pvOutputFormat)
1893 End If
1894 Select Case sOutputFormat
1899 End Select
1901 If Not OutputTo(pvObjectType, pvObjectName, sOutputFormat, sOutputFile, False) Then Goto Exit_Function
1902 End If
1903 SendObject = _SendWithAttachment(vTo, vCc, vBcc, pvSubject, Array(sOutputFile), pvMessageText, pvEditMessage)
1904 End Select
1906 Exit_Function:
1908 Exit Function
1909 Error_NotFound:
1910 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1911 Goto Exit_Function
1912 Error_Function:
1914 GoTo Exit_Function
1915 Error_Action:
1916 TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
1917 Goto Exit_Function
1918 Error_File:
1919 TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , pvObjectName)
1920 Goto Exit_Function
1923 REM -----------------------------------------------------------------------------------------------------------------------
1924 Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _
1925 , ByVal Optional pvObjectName As Variant _
1926 , ByVal Optional pvHidden As Variant _
1927 ) As Boolean
1929 If _ErrorHandler() Then On Local Error Goto Error_Function
1930 SetHiddenAttribute = False
1932 Utils._SetCalledSub(cstThisSub)
1934 If IsMissing(pvObjectType) Then Call _TraceArguments()
1935 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
1936 Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _
1937 ) Then Goto Exit_Function
1938 If IsMissing(pvObjectName) Then
1939 Select Case pvObjectType
1940 Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
1941 Case Else
1942 End Select
1943 pvObjectName = ""
1944 Else
1945 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
1946 End If
1947 If IsMissing(pvHidden) Then
1948 pvHidden = True
1949 Else
1950 If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function
1951 End If
1953 Dim oWindow As Object
1954 Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
1955 If IsNull(oWindow.Frame) Then Goto Error_NotFound
1956 oWindow.Frame.ContainerWindow.setVisible(Not pvHidden)
1957 SetHiddenAttribute = True
1959 Exit_Function:
1960 Utils._ResetCalledSub(cstThisSub)
1961 Exit Function
1962 Error_NotFound:
1963 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1964 Goto Exit_Function
1965 Error_Function:
1966 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1967 GoTo Exit_Function
1970 REM -----------------------------------------------------------------------------------------------------------------------
1971 Public Function SetOrderBy( _
1972 ByVal Optional pvOrder As Variant _
1973 , ByVal Optional pvControlName As Variant _
1974 ) As Boolean
1975 ' Sort ann open table, query, form or subform (if pvControlName present)
1977 If _ErrorHandler() Then On Local Error Goto Error_Function
1979 Utils._SetCalledSub(cstThisSub)
1980 SetOrderBy = False
1982 If IsMissing(pvOrder) Then pvOrder = ""
1983 If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function
1984 If IsMissing(pvControlName) Then pvControlName = ""
1985 If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function
1987 Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object
1988 Set oDatabase = Application._CurrentDb()
1989 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1991 sOrder = oDatabase._ReplaceSquareBrackets(pvOrder)
1993 Set oWindow = _SelectWindow()
1994 With oWindow
1995 Select Case .WindowType
1996 Case acForm
1997 Set oTarget = _DatabaseForm(._Name, pvControlName)
1998 Case acQuery, acTable
1999 If pvControlName <> "" Then Goto Exit_Function
2000 If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
2002 Set oTarget = .Frame.Controller.FormOperations.Cursor
2003 Case Else ' Ignore action
2004 Goto Exit_Function
2005 End Select
2006 End With
2008 With oTarget
2009 .Order = sOrder
2010 .reload()
2011 End With
2012 SetOrderBy = True
2014 Exit_Function:
2015 Utils._ResetCalledSub(cstThisSub)
2016 Exit Function
2017 Error_NotApplicable:
2019 Goto Exit_Function
2020 Error_Function:
2021 TraceError(TRACEABORT, Err, cstThisSub, Erl)
2022 GoTo Exit_Function
2025 REM -----------------------------------------------------------------------------------------------------------------------
2026 Public Function ShowAllrecords() As Boolean
2027 ' Removes any existing filter that exists on the current table, query or form
2029 If _ErrorHandler() Then On Local Error Goto Error_Function
2031 Utils._SetCalledSub(cstThisSub)
2032 ShowAllRecords = False
2034 Dim oWindow As Object, oDatabase As Object
2035 Set oDatabase = Application._CurrentDb()
2036 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
2038 Set oWindow = _SelectWindow()
2039 Select Case oWindow.WindowType
2040 Case acForm, acQuery, acTable
2041 RunCommand(acCmdRemoveFilterSort)
2042 ShowAllrecords = True
2043 Case Else ' Ignore action
2044 End Select
2046 Exit_Function:
2047 Utils._ResetCalledSub(cstThisSub)
2048 Exit Function
2049 Error_NotApplicable:
2051 Goto Exit_Function
2052 Error_Function:
2053 TraceError(TRACEABORT, Err, cstThisSub, Erl)
2054 GoTo Exit_Function
2057 REM -----------------------------------------------------------------------------------------------------------------------
2058 REM --- PRIVATE FUNCTIONS ---
2059 REM -----------------------------------------------------------------------------------------------------------------------
2060 Private Function _CheckColumnType(pvFindWhat As Variant, vDataField As Variant) As Boolean
2061 ' Return true if both arguments of the same type
2062 ' vDataField is a ResultSet column
2064 Dim bFound As Boolean
2065 bFound = False
2066 With com.sun.star.sdbc.DataType
2067 Select Case vDataField.Type
2068 Case .DATE, .TIME, .TIMESTAMP
2069 If VarType(pvFindWhat) = vbDate Then bFound = True
2070 Case .TINYINT, .SMALLINT, .INTEGER, .BIGINT, .FLOAT, .REAL, .DOUBLE, .NUMERIC, .DECIMAL
2071 If Utils._InList(VarType(pvFindWhat), Utils._AddNumeric()) Then bFound = True
2072 Case .CHAR, .VARCHAR, .LONGVARCHAR
2073 If VarType(pvFindWhat) = vbString Then bFound = True
2074 Case Else
2075 End Select
2076 End With
2078 _CheckColumnType = bFound
2082 REM -----------------------------------------------------------------------------------------------------------------------
2083 Sub _ConvertDataDescriptor( ByRef poSource As Object _
2084 , ByVal piSourceRDBMS As Integer _
2085 , ByRef poTarget As Object _
2086 , ByRef poDatabase As Object _
2087 , ByVal Optional pbKey As Boolean _
2088 )
2089 ' Convert source column descriptor to target descriptor
2090 ' If RDMSs identical, simply move property by property
2091 ' Otherwise
2092 ' - Use Type conversion tables (cfr. DataTypes By RDBMS.ods case study)
2093 ' - Select among synonyms the entry with the lowest Precision at least >= source Precision
2094 ' - Derive TypeName and Precision values
2096 Dim vTypesReference() As Variant, vTypes() As Variant, vTypeNames() As Variant
2097 Dim i As Integer, iType As Integer, iTypeAlias As Integer
2098 Dim iNbTypes As Integer, iBestFit As Integer, lFitPrecision As Long, lPrecision As Long
2100 On Local Error Goto Error_Sub
2101 If IsMissing(pbKey) Then pbKey = False
2103 poTarget.Name = poSource.Name
2104 poTarget.Description = poSource.Description
2105 If Not pbKey Then
2106 poTarget.ControlDefault = poSource.ControlDefault
2107 poTarget.FormatKey = poSource.FormatKey
2108 poTarget.HelpText = poSource.HelpText
2109 poTarget.Hidden = poSource.Hidden
2110 End If
2111 poTarget.IsCurrency = poSource.IsCurrency
2112 poTarget.IsNullable = poSource.IsNullable
2113 poTarget.Scale = poSource.Scale
2115 If piSourceRDBMS = poDatabase._RDBMS Or poDatabase._RDBMS = DBMS_UNKNOWN Then
2116 poTarget.Type = poSource.Type
2117 poTarget.Precision = poSource.Precision
2118 poTarget.TypeName = poSource.TypeName
2119 Goto Exit_Sub
2120 End If
2122 ' Search DataType compatibility
2123 With poDatabase
2124 ' Find source datatype entry in Reference array
2125 iType = -1
2126 For i = 0 To UBound(._ColumnTypesReference)
2127 If ._ColumnTypesReference(i) = poSource.Type Then
2128 iType = i
2129 Exit For
2130 End If
2131 Next i
2132 If iType = -1 Then Goto Error_Compatibility
2133 iTypeAlias = ._ColumnTypesAlias(iType)
2134 ' Find best choice for the datatype of the target column
2135 iNbTypes = UBound(._ColumnTypes)
2136 iBestFit = -1
2138 For i = 0 To iNbTypes
2139 If ._ColumnTypes(i) = iTypeAlias Then ' Minimal fit = correct datatype
2140 lPrecision = ._ColumnPrecisions(i)
2141 If iBestFit = -1 _
2142 Or (iBestFit > -1 And poSource.Precision > 0 And lPrecision >= poSource.Precision And lPrecision < lFitPrecision) _
2143 Or (iBestFit > -1 And poSource.Precision = 0 And lPrecision > lFitPrecision) Then ' First fit or better fit
2144 iBestFit = i
2145 lFitPrecision = lPrecision
2146 End If
2147 End If
2148 Next i
2149 If iBestFit = -1 Then Goto Error_Compatibility
2150 poTarget.Type = iTypeAlias
2151 poTarget.Precision = lFitPrecision
2152 poTarget.TypeName = ._ColumnTypeNames(iBestFit)
2153 End With
2155 Exit_Sub:
2156 Exit Sub
2157 Error_Compatibility:
2159 Goto Exit_Sub
2160 Error_Sub:
2162 Goto Exit_Sub
2165 REM -----------------------------------------------------------------------------------------------------------------------
2166 Private Function _DatabaseForm(psForm As String, psControl As String)
2167 'Return DatabaseForm element of Form object (based on psForm which is known as a real form name)
2168 'or of SubForm object (based on psControl which is checked for being a subform)
2170 Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer
2171 Dim bFound As Boolean, i As Integer, sName As String
2173 Set oForm = Application.Forms(psForm)
2175 With oForm.DatabaseForm
2176 iControlCount = .getCount()
2177 bFound = False
2179 sControls() = .getElementNames()
2180 sName = UCase(Utils._Trim(psControl))
2182 If UCase(sControls(i)) = sName Then
2183 bFound = True
2184 Exit For
2185 End If
2186 Next i
2187 End If
2188 End With
2189 If bFound Then sName = sControls(i) Else Goto Trace_NotFound
2190 Set oControl = oForm.Controls(sName)
2191 If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound
2192 Set _DatabaseForm = oControl.Form.DatabaseForm
2193 Else
2194 Set _DatabaseForm = oForm.DatabaseForm
2195 End If
2197 Exit_Function:
2198 Exit Function
2199 Trace_NotFound:
2200 TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm))
2201 Goto Exit_Function
2202 Trace_SubFormNotFound:
2203 TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm))
2204 Goto Exit_Function
2207 REM -----------------------------------------------------------------------------------------------------------------------
2208 Private Sub _DispatchCommand(ByVal psCommand As String)
2210 Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String
2211 Dim oResult As Variant
2212 Dim sCommand As String
2214 Set oDocument = _SelectWindow().Frame
2216 sTargetFrameName = ""
2217 oResult = oDispatcher.executeDispatch(oDocument, psCommand, sTargetFrameName, 0, oArgs())
2221 REM -----------------------------------------------------------------------------------------------------------------------
2222 Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal psLastComponent As String) As String
2223 ' Return "Forms!myForm" from "Forms!myForm!datField" and "datField"
2225 If Len(psShortcut) > Len(psLastComponent) Then
2227 Else
2228 _getUpperShortcut = psShortcut
2229 End If
2231 End Function ' _getUpperShortcut
2233 REM -----------------------------------------------------------------------------------------------------------------------
2234 Private Function _OpenObject(ByVal psObjectType As String _
2235 , ByVal pvObjectName As Variant _
2236 , ByVal pvView As Variant _
2237 , ByVal pvDataMode As Variant _
2238 ) As Boolean
2240 If _ErrorHandler() Then On Local Error Goto Error_Function
2242 _OpenObject = False
2243 If Not (Utils._CheckArgument(pvObjectName, 1, vbString) _
2244 And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _
2245 And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _
2246 ) Then Goto Exit_Function
2247 Dim oDatabase As Object
2248 Set oDatabase = Application._CurrentDb()
2249 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
2251 Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object
2252 Dim i As Integer, bFound As Boolean, lComponent As Long, oQuery As Object
2254 ' Check existence of object and find its exact (case-sensitive) name
2255 Select Case psObjectType
2257 sObjects = oDatabase.Connection.getTables.ElementNames()
2258 lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE
2260 sObjects = oDatabase.Connection.getQueries.ElementNames()
2261 lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY
2263 sObjects = oDatabase.Document.getReportDocuments.ElementNames()
2264 lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT
2265 End Select
2266 bFound = False
2267 For i = 0 To UBound(sObjects)
2268 If UCase(pvObjectName) = UCase(sObjects(i)) Then
2269 sObjectName = sObjects(i)
2270 bFound = True
2271 Exit For
2272 End If
2273 Next i
2274 If Not bFound Then Goto Trace_NotFound
2277 Set oQuery = Application._CurrentDb().QueryDefs(pvObjectName)
2278 If oQuery.pType <> dbQSelect Then
2279 _OpenObject = oQuery.Execute()
2280 GoTo Exit_Function
2281 End If
2282 End If
2283 Set oController = oDatabase.Document.CurrentController
2284 Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign ))
2285 _OpenObject = True
2287 Exit_Function:
2288 Set oObject = Nothing
2289 Set oQuery = Nothing
2290 Set oController = Nothing
2291 Exit Function
2292 Error_Function:
2294 GoTo Exit_Function
2295 Trace_Error:
2296 TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName))
2297 Goto Exit_Function
2298 Error_NotApplicable:
2300 Goto Exit_Function
2301 Trace_NotFound:
2302 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName))
2303 Goto Exit_Function
2306 REM -----------------------------------------------------------------------------------------------------------------------
2307 Private Function _PromptFormat(ByVal pvList As Variant) As String
2308 ' Return user selection in Format dialog
2310 Dim oDialog As Object, iOKCancel As Integer, oControl As Object
2312 Set oDialog = CreateUnoDialog(Utils._GetDialogLib().dlgFormat)
2332 oControl.Text = pvList(0)
2333 oControl.StringItemList = pvList
2334 Else
2335 oControl.Text = ""
2336 oControl.StringItemList = Array()
2337 End If
2339 iOKCancel = oDialog.Execute()
2340 Select Case iOKCancel
2342 _PromptFormat = oControl.Text
2344 _PromptFormat = ""
2345 Case Else
2346 End Select
2347 oDialog.Dispose()
2351 REM -----------------------------------------------------------------------------------------------------------------------
2352 Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional ByVal psWindow As String) As Object
2353 ' No argument: find active window
2355 ' Return a _Window object type describing the found window
2357 Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer
2358 Dim bFound As Boolean, bActive As Boolean, sName As String, iType As Integer, sDocumentType As String
2359 Dim sImplementation As String, vLocation() As Variant
2360 Dim oWindow As _Window
2361 Dim vPersistent As Variant, oForm As Object
2363 If _ErrorHandler() Then On Local Error Goto Error_Function
2365 bActive = IsMissing(piWindowType)
2366 If IsMissing(psWindow) Then psWindow = ""
2367 Set oWindow.Frame = Nothing
2368 oWindow.DocumentType = ""
2369 If bActive Then
2370 oWindow.WindowType = acDefault
2371 oWindow._Name = ""
2372 Else
2373 oWindow.WindowType = piWindowType
2374 Select Case piWindowType
2375 Case acBasicIDE, acDatabaseWindow : oWindow._Name = ""
2376 Case Else : oWindow._Name = psWindow
2377 End Select
2378 End If
2379 iType = acDefault
2380 sDocumentType = ""
2383 Set oEnum = oDesk.Components().createEnumeration
2384 Do While oEnum.hasMoreElements
2385 Set oComp = oEnum.nextElement
2386 If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = ""
2387 Select Case sImplementation
2389 Set oFrame = oComp.CurrentController.Frame
2390 iType = acBasicIDE
2391 sName = ""
2393 Set oFrame = oComp.CurrentController.Frame
2394 iType = acDatabaseWindow
2395 sName = ""
2398 Select Case oComp.Identifier
2400 iType = acForm
2402 iType = acReport
2405 If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = ""
2406 iType = acDocument
2407 sDocumentType = docWriter
2408 End Select
2409 If iType = acForm Then ' Identify persistent Form name
2411 sName = _GetHierarchicalName(vPersistent(UBound(vPersistent) - 1))
2412 ElseIf iType = acReport Then ' Identify Report name
2413 For i = 0 To UBound(oComp.Args())
2415 sName = oComp.Args(i).Value
2416 Exit For
2417 End If
2418 Next i
2419 End If
2420 Set oFrame = oComp.CurrentController.Frame
2421 End If
2423 Set oFrame = oComp.Frame
2424 If Not IsEmpty(oComp.Selection) Then ' Empty for (F4) DatasourceBrowser !!
2425 For i = 0 To UBound(oComp.Selection())
2427 sName = oComp.Selection(i).Value
2429 Select Case oComp.selection(i).Value
2430 Case com.sun.star.sdb.CommandType.TABLE
2431 iType = acTable
2432 Case com.sun.star.sdb.CommandType.QUERY
2433 iType = acQuery
2434 Case com.sun.star.sdb.CommandType.COMMAND
2435 iType = acQuery ' SQL for future use ?
2436 End Select
2437 End If
2438 Next i
2439 ' Else ignore
2440 End If
2441 Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode
2442 If Not bActive Then
2443 If UCase(Right(oComp.Title, Len(psWindow))) = UCase(psWindow) Then ' No rigorous mean found to identify Name
2444 Set oFrame = oComp.Frame
2445 Select Case sImplementation
2448 End Select
2449 sName = Right(oComp.Title, Len(psWindow))
2450 End If
2451 Else
2452 Set oFrame = Nothing
2453 End If
2455 Set oFrame = oComp.Frame
2456 iType = acDiagram
2457 sName = ""
2459 Set oFrame = oComp.Frame
2460 iType = acWelcome
2461 sName = ""
2462 Case Else ' Other Calc, ..., whatever documents
2465 If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = ""
2466 iType = acDocument
2468 Select Case oComp.Identifier
2473 Case Else : sDocumentType = ""
2474 End Select
2475 End If
2476 Set oFrame = oComp.CurrentController.Frame
2477 End If
2478 End Select
2479 If bActive And Not IsNull(oFrame) Then
2480 If oFrame.ContainerWindow.IsActive() Then
2481 bFound = True
2482 Exit Do
2483 End If
2484 ElseIf iType = piWindowType And UCase(sName) = UCase(psWindow) Then
2485 bFound = True
2486 Exit Do
2487 End If
2488 Loop
2490 If bFound Then
2491 Set oWindow.Frame = oFrame
2492 oWindow._Name = sName
2493 oWindow.WindowType = iType
2494 oWindow.DocumentType = sDocumentType
2495 Else
2496 Set oWindow.Frame = Nothing
2497 End If
2499 Exit_Function:
2500 Set _SelectWindow = oWindow
2501 Exit Function
2502 Error_Function:
2504 GoTo Exit_Function
2507 REM -----------------------------------------------------------------------------------------------------------------------
2508 Private Function _SendWithAttachment( _
2509 ByVal pvRecipients() As Variant _
2510 , ByVal pvCcRecipients() As Variant _
2511 , ByVal pvBccRecipients() As Variant _
2512 , ByVal psSubject As String _
2513 , ByVal pvAttachments() As Variant _
2514 , ByVal pvBody As String _
2515 , ByVal pbEditMessage As Boolean _
2516 ) As Boolean
2518 ' Send message with attachments
2519 If _ErrorHandler() Then On Local Error Goto Error_Function
2520 _SendWithAttachment = False
2522 Const cstWindows = 1
2523 Const cstLinux = 4
2525 Dim oServiceMail as Object, oMail As Object, oMessage As Object, vFlag As Variant
2526 Dim vCc() As Variant, i As Integer, iOS As Integer, sProduct As String, bMailProvider As Boolean
2528 'OPENOFFICE <= 3.6 and LIBREOFFICE have XSimple...Mail interface while OPENOFFICE >= 4.0 has XSystemMailProvider interface
2529 sProduct = UCase(Utils._GetProductName())
2530 bMailProvider = ( Left(sProduct, 4) = "OPEN" And Left(_GetProductName("VERSION"), 3) >= "4.0" )
2532 iOS = GetGuiType()
2533 Select Case iOS
2534 Case cstLinux
2536 Case cstWindows
2537 If bMailProvider Then oServiceMail = createUnoService("com.sun.star.system.SystemMailProvider") _
2539 Case Else
2540 Goto Error_Mail
2541 End Select
2543 If bMailProvider Then Set oMail = oServiceMail.queryMailClient() _
2544 Else Set oMail = oServiceMail.querySimpleMailClient()
2545 If IsNull(oMail) Then Goto Error_Mail
2550 Else
2553 vCc(i) = pvRecipients(i + 1)
2554 Next i
2555 For i = UBound(pvRecipients) To UBound(vCc)
2556 vCc(i) = pvCcRecipients(i - UBound(pvRecipients))
2557 Next i
2558 End If
2560 If bMailProvider Then
2561 Set oMessage = oMail.createMailMessage()
2563 If psSubject <> "" Then oMessage.Subject = psSubject
2564 Select Case iOS ' Not published differences between com.sun.star.system.SimpleCommandMail and SimpleSystemMail
2565 Case cstLinux
2567 If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = Array(Join(pvBccRecipients, cstSemiColon))
2568 Case cstWindows
2571 End Select
2573 If pvBody <> "" Then oMessage.Body = pvBody
2574 If pbEditMessage Then
2575 vFlag = com.sun.star.system.MailClientFlags.DEFAULTS
2576 Else
2577 vFlag = com.sun.star.system.MailClientFlags.NO_USER_INTERFACE
2578 End If
2579 oMail.sendMailMessage(oMessage, vFlag)
2580 Else
2581 Set oMessage = oMail.createSimpleMailMessage() ' Body NOT SUPPORTED !
2583 If psSubject <> "" Then oMessage.setSubject(psSubject)
2584 Select Case iOS
2585 Case cstLinux
2587 If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(Array(Join(pvBccRecipients, cstSemiColon)))
2588 Case cstWindows
2591 End Select
2593 If pbEditMessage Then
2594 vFlag = com.sun.star.system.SimpleMailClientFlags.DEFAULTS
2595 Else
2596 vFlag = com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE
2597 End If
2598 oMail.sendSimpleMailMessage(oMessage, vFlag)
2599 End If
2601 _SendWithAttachment = True
2603 Exit_Function:
2604 Exit Function
2605 Error_Function:
2607 Goto Exit_Function
2608 Error_Mail:
2609 TraceError(TRACEFATAL, ERRSENDMAIL, Utils._CalledSub(), 0)
2610 Goto Exit_Function
2613 REM -----------------------------------------------------------------------------------------------------------------------
2614 Private Function _SendWithoutAttachment(ByVal pvTo As Variant _
2615 , ByVal pvCc As Variant _
2616 , ByVal pvBcc As Variant _
2617 , ByVal psSubject As String _
2618 , ByVal psBody As String _
2619 ) As Boolean
2620 'Send simple message with mailto: syntax
2621 Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object
2624 If _ErrorHandler() Then On Local Error Goto Error_Function
2632 & Iif(sCc = "", "", "cc=" & sCc & "&") _
2633 & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _
2634 & Iif(psSubject = "", "", "subject=" & psSubject & "&") _
2635 & Iif(psBody = "", "", "body=" & psBody & "&")
2636 If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1)
2637 sMailTo = ConvertToUrl(sMailTo)
2642 _SendWithoutAttachment = True
2644 Exit_Function:
2645 Exit Function
2646 Error_Function:
2648 _SendWithoutAttachment = False
2649 Goto Exit_Function
2652 REM -----------------------------------------------------------------------------------------------------------------------
2653 Private Sub _ShellExecute(sCommand As String)
2654 ' Execute shell command
2656 Dim oShell As Object
2658 oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.DEFAULTS)
2662 </script:module>