| blob | 261aa26b5ce8955aff0ea4de976446b1265f8d34 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="DoCmd" script:language="StarBasic">REM =======================================================================================================================
4 REM === The Access2Base library is a part of the LibreOffice project. ===
5 REM === Full documentation is available on http://www.access2base.com ===
6 REM =======================================================================================================================
8 Option Explicit
10 Type _FindParams
12 FindWhat As Variant
13 Match As Integer
14 MatchCase As Boolean
15 Search As Integer
16 SearchAsFormatted As Boolean ' Must be False
17 FindFirst As Boolean
18 OnlyCurrentField As Integer
19 Form As String ' Shortcut
20 GridControl As String ' Shortcut
21 Target As String ' Shortcut
23 LastColumn As Integer ' Last column explored - 0 ... N-1 index in next arrays; 0 if OnlyCurrentField = acCurrent
24 ColumnNames() As String ' Array of column names in grid with boundfield and of same type as FindWhat
25 ResultSetIndex() As Integer ' Array of column numbers in ResultSet
26 End Type
28 'Global _gFind As _FindParams
30 Type _Window
31 Frame As Object ' com.sun.star.comp.framework.Frame
32 _Name As String ' Object Name
33 WindowType As Integer ' One of the object types
34 DocumentType As String ' Writer, Calc, ... - Only if WindowType = acDocument
35 End Type
37 REM VBA allows call to actions with missing arguments e.g. OpenForm("aaa",,"[field]=2")
38 REM in StarBasic IsMissing requires Variant parameters
40 REM -----------------------------------------------------------------------------------------------------------------------
41 Public Function ApplyFilter( _
42 ByVal Optional pvFilter As Variant _
43 , ByVal Optional pvSQL As Variant _
44 , ByVal Optional pvControlName As Variant _
45 ) As Boolean
46 ' Set filter on open table, query, form or subform (if pvControlName present)
48 If _ErrorHandler() Then On Local Error Goto Error_Function
50 Utils._SetCalledSub(cstThisSub)
51 ApplyFilter = False
53 If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments()
54 If IsMissing(pvFilter) Then pvFilter = ""
55 If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function
56 If IsMissing(pvSQL) Then pvSQL = ""
57 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
58 If IsMissing(pvControlName) Then pvControlName = ""
59 If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function
61 Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object
62 Set oDatabase = Application._CurrentDb()
63 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
65 If pvSQL <> "" _
66 Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _
67 Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter)
69 Set oWindow = _SelectWindow()
70 With oWindow
71 Select Case .WindowType
72 Case acForm
73 Set oTarget = _DatabaseForm(._Name, pvControlName)
74 Case acQuery, acTable
75 If pvControlName <> "" Then Goto Exit_Function
76 If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
78 Set oTarget = .Frame.Controller.FormOperations.Cursor
79 Case Else ' Ignore action
80 Goto Exit_Function
81 End Select
82 End With
84 With oTarget
85 .Filter = sFilter
86 .ApplyFilter = True
87 .reload()
88 End With
89 ApplyFilter = True
91 Exit_Function:
92 Utils._ResetCalledSub(cstThisSub)
93 Exit Function
94 Error_NotApplicable:
96 Goto Exit_Function
97 Error_Function:
98 TraceError(TRACEABORT, Err, cstThisSub, Erl)
99 GoTo Exit_Function
102 REM -----------------------------------------------------------------------------------------------------------------------
103 Public Function mClose(Optional ByVal pvObjectType As Variant _
104 , Optional ByVal pvObjectName As Variant _
105 , Optional ByVal pvSave As Variant _
106 ) As Boolean
107 If _ErrorHandler() Then On Local Error Goto Error_Function
110 Utils._SetCalledSub(cstThisSub)
111 mClose = False
112 If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments()
113 If IsMissing(pvSave) Then pvSave = acSavePrompt
114 If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
115 Array(acTable, acQuery, acForm, acReport)) _
116 And Utils._CheckArgument(pvObjectName, 2, vbString) _
117 And Utils._CheckArgument(pvSave, 3, Utils._AddNumeric(), Array(acSavePrompt)) _
118 ) Then Goto Exit_Function
120 Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object
121 Dim i As Integer, bFound As Boolean, lComponent As Long
122 Dim oDatabase As Object
123 Set oDatabase = Application._CurrentDb()
124 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
126 ' Check existence of object and find its exact (case-sensitive) name
127 Select Case pvObjectType
128 Case acForm
129 sObjects = oDatabase.Document.getFormDocuments.ElementNames()
130 lComponent = com.sun.star.sdb.application.DatabaseObject.FORM
131 Case acTable
132 sObjects = oDatabase.Connection.getTables.ElementNames()
133 lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE
134 Case acQuery
135 sObjects = oDatabase.Connection.getQueries.ElementNames()
136 lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY
137 Case acReport
138 sObjects = oDatabase.Document.getReportDocuments.ElementNames()
139 lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT
140 End Select
141 bFound = False
142 For i = 0 To UBound(sObjects)
143 If UCase(pvObjectName) = UCase(sObjects(i)) Then
144 sObjectName = sObjects(i)
145 bFound = True
146 Exit For
147 End If
148 Next i
149 If Not bFound Then Goto Trace_NotFound
151 Select Case pvObjectType
152 Case acForm
153 Set oController = oDatabase.Document.getFormDocuments.getByName(sObjectName)
154 mClose = oController.close()
155 Case acTable, acQuery ' Not optimal but it works !!
156 Set oController = oDatabase.Document.CurrentController
157 Set oObject = oController.loadComponent(lComponent, sObjectName, False)
158 oObject.frame.close(False)
159 mClose = True
160 Case acReport
161 Set oController = oDatabase.Document.getReportDocuments.getByName(sObjectName)
162 mClose = oController.close()
163 End Select
166 Exit_Function:
167 Set oObject = Nothing
168 Set oController = Nothing
169 Utils._ResetCalledSub(cstThisSub)
170 Exit Function
171 Error_Function:
173 GoTo Exit_Function
174 Trace_Error:
175 TraceError(TRACEFATAL, ERRCLOSEOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName))
176 Goto Exit_Function
177 Trace_NotFound:
178 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName))
179 Goto Exit_Function
180 Error_NotApplicable:
182 Goto Exit_Function
185 REM -----------------------------------------------------------------------------------------------------------------------
186 Public Function CopyObject(ByVal Optional pvDestinationDatabase As Variant _
187 , ByVal Optional pvNewName As Variant _
188 , ByVal Optional pvSourceType As Variant _
189 , ByVal Optional pvSourceName As Variant _
190 ) As Boolean
191 ' Copies tables and queries into identical (new) objects
192 If _ErrorHandler() Then On Local Error Goto Error_Function
194 Utils._SetCalledSub(cstThisSub)
195 CopyObject = False
197 If IsMissing(pvDestinationDatabase) Then pvDestinationDatabase = ""
198 If Not Utils._CheckArgument(pvDestinationDatabase, 1, vbString, "") Then Goto Exit_Function
199 If IsMissing(pvNewName) Then Call _TraceArguments()
200 If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function
201 If IsMissing(pvSourceType) Then Call _TraceArguments()
202 If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _
203 ) Then Goto Exit_Function
204 If IsMissing(pvSourceName) Then Call _TraceArguments()
205 If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto Exit_Function
207 Dim oSource As Object, oTarget As Object, oDatabase As Object
208 Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object, oTargetCol As Object
209 Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object
210 Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant
212 Set oDatabase = Application._CurrentDb()
214 With oDatabase
215 If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
216 Select Case pvSourceType
218 Case acQuery
219 Set oSource = .QueryDefs(pvSourceName, True)
220 If IsNull(oSource) Then Goto Error_NotFound
221 Set oTarget = .QueryDefs(pvNewName, True)
222 If Not IsNull(oTarget) Then .Connection.getQueries.dropByName(oTarget.Name) ' a query with same name exists already ... drop it
223 If oSource.Query.EscapeProcessing Then
224 Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL)
225 Else
226 Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough)
227 End If
228 ' Save .odb document
229 .Document.store()
231 Case acTable
232 Set oSource = .TableDefs(pvSourceName, True)
233 If IsNull(oSource) Then Goto Error_NotFound
234 Set oTarget = .TableDefs(pvNewName, True)
235 If Not IsNull(oTarget) Then .Connection.getTables.dropByName(oTarget.Name) ' a table with same name exists already ... drop it
236 ' Copy source table columns
237 Set oSourceTable = oSource.Table
238 Set oTarget = .Connection.getTables.createDataDescriptor
239 oTarget.Description = oSourceTable.Description
240 oTarget.Name = pvNewName
241 oTarget.Type = oSourceTable.Type
242 Set oSourceColumns = oSourceTable.Columns
243 Set oTargetCol = oTarget.Columns.createDataDescriptor
245 ' Append each individual column to the table descriptor
246 Set oSourceCol = oSourceColumns.getByIndex(i)
247 oTargetCol.Name = oSourceCol.Name
248 oTargetCol.ControlDefault = oSourceCol.ControlDefault
249 oTargetCol.Description = oSourceCol.Description
250 oTargetCol.FormatKey = oSourceCol.FormatKey
251 oTargetCol.HelpText = oSourceCol.HelpText
252 oTargetCol.Hidden = oSourceCol.Hidden
253 oTargetCol.IsCurrency = oSourceCol.IsCurrency
254 oTargetCol.IsNullable = oSourceCol.IsNullable
255 oTargetCol.Precision = oSourceCol.Precision
256 oTargetCol.Scale = oSourceCol.Scale
257 oTargetCol.Type = oSourceCol.Type
258 oTargetCol.TypeName = oSourceCol.TypeName
259 oTarget.Columns.appendByDescriptor(oTargetCol)
260 Next i
261 ' Copy keys
262 Set oSourceKeys = oSourceTable.Keys
263 Set oTargetKey = oTarget.Keys.createDataDescriptor()
265 ' Append each key to table descriptor
266 Set oSourceKey = oSourceKeys.getByIndex(i)
267 oTargetKey.DeleteRule = oSourceKey.DeleteRule
268 oTargetKey.Name = oSourceKey.Name
269 oTargetKey.ReferencedTable = oSourceKey.ReferencedTable
270 oTargetKey.Type = oSourceKey.Type
271 ' If oSourceKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY Then vPrimaryKeys = oSourceKey.Columns.getElementNames()
272 oTargetKey.UpdateRule = oSourceKey.UpdateRule
273 Set oTargetCol = oTargetKey.Columns.createDataDescriptor()
275 Set oSourceCol = oSourceKey.Columns.getByIndex(j)
276 oTargetCol.Name = oSourceCol.Name
277 oTargetCol.Description = oSourceCol.Description
278 oTargetCol.IsCurrency = oSourceCol.IsCurrency
279 oTargetCol.IsNullable = oSourceCol.IsNullable
280 oTargetCol.Precision = oSourceCol.Precision
281 oTargetCol.Scale = oSourceCol.Scale
282 oTargetCol.Type = oSourceCol.Type
283 oTargetCol.TypeName = oSourceCol.TypeName
284 oTargetKey.Columns.appendByDescriptor(oTargetCol)
285 Next j
286 oTarget.Keys.appendByDescriptor(oTargetKey)
287 Next i
288 ' Duplicate table whole design
289 .Connection.getTables.appendByDescriptor(oTarget)
290 ' Copy data
291 sSql = "INSERT INTO [" & pvNewName & "] SELECT [" & oSource.Name & "].* FROM [" & oSource.Name & "]"
292 DoCmd.RunSQL(sSql, dbSQLPassthrough)
294 Case Else
295 End Select
296 End With
298 CopyObject = True
300 Exit_Function:
301 Utils._ResetCalledSub(cstThisSub)
302 Set oSourceCol = Nothing
303 Set oSourceKey = Nothing
304 Set oSourceKeys = Nothing
305 Set oSource = Nothing
306 Set oSourceTable = Nothing
307 Set oSourceColumns = Nothing
308 Set oTargetCol = Nothing
309 Set oTargetKey = Nothing
310 Set oTarget = Nothing
311 Exit Function
312 Error_NotFound:
313 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName))
314 Goto Exit_Function
315 Error_NotApplicable:
317 Goto Exit_Function
318 Error_Function:
319 TraceError(TRACEABORT, Err, cstThisSub, Erl)
320 GoTo Exit_Function
323 REM -----------------------------------------------------------------------------------------------------------------------
324 Public Function FindNext() As Boolean
325 ' Must be called after a FindRecord
326 ' Execute instructions set in FindRecord object
328 If _ErrorHandler() Then On Local Error Goto Error_Function
329 FindNext = False
332 Dim ofForm As Object, ocGrid As Object
333 Dim i As Integer, lInitialRow As Long, lFindRow As Long
334 Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean
335 Dim vFindValue As Variant, oFindrecord As Object
337 Set oFindRecord = _A2B_.FindRecord
338 If IsNull(oFindRecord) Then GoTo Error_FindRecord
339 With oFindRecord
341 If .FindRecord = 0 Then Goto Error_FindRecord
342 .FindRecord = 0
343 Set ofForm = getObject(.Form)
344 If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola
345 Set ocGrid = getObject(.GridControl)
347 ' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween
350 lInitialRow = .LastRow ' Used if Search = acSearchAll
352 bFound = False
353 lFindRow = .LastRow
354 b2ndRound = False
355 Do
356 ' Last column ? Go to next row
357 If .LastColumn >= UBound(.ColumnNames) Then
358 bStop = False
359 If ofForm.DatabaseForm.isAfterLast() And .Search = acUp Then
360 ofForm.DatabaseForm.last()
361 ElseIf ofForm.DatabaseForm.isLast() And .Search = acSearchAll Then
362 ofForm.DatabaseForm.first()
363 b2ndRound = True
364 ElseIf ofForm.DatabaseForm.isBeforeFirst() And (.Search = acDown Or .Search = acSearchAll) Then
365 ofForm.DatabaseForm.first()
366 ElseIf ofForm.DatabaseForm.isFirst() And .search = acUp Then
367 ofForm.DatabaseForm.beforeFirst()
368 bStop = True
369 ElseIf ofForm.DatabaseForm.isLast() And .search = acDown Then
370 ofForm.DatabaseForm.afterLast()
371 bStop = True
372 ElseIf .Search = acUp Then
373 ofForm.DatabaseForm.previous()
374 Else
375 ofForm.DatabaseForm.next()
376 End If
377 lFindRow = ofForm.DatabaseForm.getRow()
378 If bStop Or (.Search = acSearchAll And lFindRow >= lInitialRow And b2ndRound) Then
379 ofForm.DatabaseForm.absolute(lInitialRow)
380 Exit Do
381 End If
382 .LastColumn = 0
383 Else
384 .LastColumn = .LastColumn + 1
385 End If
387 ' Examine column contents
388 If .LastColumn <= UBound(.ColumnNames) Then
389 For i = .LastColumn To UBound(.ColumnNames)
390 vFindValue = Utils._getResultSetColumnValue(ofForm.DatabaseForm.createResultSet(), .ResultSetIndex(i))
391 Select Case VarType(.FindWhat)
392 Case vbDate, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
393 bFound = ( .FindWhat = vFindValue )
394 Case vbString
395 Select Case .Match
396 Case acStart
397 If .MatchCase Then
398 bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue )
399 Else
400 bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) )
401 End If
402 Case acAnyWhere
403 If .MatchCase Then
405 Else
407 End If
408 Case acEntire
409 If .MatchCase Then
410 bFound = ( .FindWhat = vFindValue )
411 Else
412 bFound = ( UCase(.FindWhat) = UCase(vFindValue) )
413 End If
414 End Select
415 End Select
416 If bFound Then
417 .LastColumn = i
418 Exit For
419 End If
420 Next i
421 End If
422 Loop While Not bFound
424 .LastRow = lFindRow
425 If bFound Then
426 ocGrid.Controls(.ColumnNames(.LastColumn)).setFocus()
427 .FindRecord = 1
428 FindNext = True
429 End If
431 End With
433 Exit_Function:
435 Exit Function
436 Error_Function:
438 GoTo Exit_Function
439 Error_FindRecord:
440 TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0)
441 Goto Exit_Function
444 REM -----------------------------------------------------------------------------------------------------------------------
445 Public Function FindRecord(Optional ByVal pvFindWhat As Variant _
446 , Optional ByVal pvMatch As Variant _
447 , Optional ByVal pvMatchCase As Variant _
448 , Optional ByVal pvSearch As Variant _
449 , Optional ByVal pvSearchAsFormatted As Variant _
450 , Optional ByVal pvTargetedField As Variant _
451 , Optional ByVal pvFindFirst As Variant _
452 ) As Boolean
454 'Find a value (string or other) in the underlying data of a gridcontrol
455 'Search in all columns or only in one single control
456 ' see pvTargetedField = acAll or acCurrent
457 ' pvTargetedField may also be a shortcut to a GridControl or one of its subcontrols
458 'Initialize _Findrecord structure in Database root and call FindNext() to set cursor on found value
460 If _ErrorHandler() Then On Local Error Goto Error_Function
461 FindRecord = False
464 If IsMissing(pvFindWhat) Or pvFindWhat = "" Then Call _TraceArguments()
465 If IsMissing(pvMatch) Then pvMatch = acEntire
466 If IsMissing(pvMatchCase) Then pvMatchCase = False
467 If IsMissing(pvSearch) Then pvSearch = acSearchAll
468 If IsMissing(pvSearchAsFormatted) Then pvSearchAsFormatted = False ' Anyway only False supported
469 If IsMissing(pvTargetedField) Then pvTargetedField = acCurrent
470 If IsMissing(pvFindFirst) Then pvFindFirst = True
471 If Not (Utils._CheckArgument(pvFindWhat, 1, Utils._AddNumeric(Array(vbString, vbDate))) _
472 And Utils._CheckArgument(pvMatch, 2, Utils._AddNumeric(), Array(acAnywhere, acEntire, acStart)) _
473 And Utils._CheckArgument(pvMatchCase, 3, vbBoolean) _
474 And Utils._CheckArgument(pvSearch, 4, Utils._AddNumeric(), Array(acDown, acSearchAll, acUp)) _
475 And Utils._CheckArgument(pvSearchAsFormatted, 5, vbBoolean, Array(False)) _
476 And Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(vbString)) _
477 And Utils._CheckArgument(pvFindFirst, 7, vbBoolean) _
478 ) Then Exit Function
479 If VarType(pvTargetedField) <> vbString Then
480 If Not Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(), Array(acAll, acCurrent)) Then Exit Function
481 End If
483 Dim ocTarget As Object, i As Integer, j As Integer, vNames() As Variant, iCount As Integer, vIndexes() As Variant
484 Dim vColumn As Variant, vDataField As Variant, ofParentForm As Variant, oColumns As Object, vParentGrid As Object
485 Dim bFound As Boolean, ocGridControl As Object, iFocus As Integer
486 Dim oFindRecord As _FindParams
487 With oFindRecord
488 .FindRecord = 0
489 .FindWhat = pvFindWhat
490 .Match = pvMatch
491 .MatchCase = pvMatchCase
492 .Search = pvSearch
493 .SearchAsFormatted = pvSearchAsFormatted
494 .FindFirst = pvFindFirst
496 ' Determine target
500 Select Case True
502 Case VarType(pvTargetedField) = vbString
503 Set ocTarget = getObject(pvTargetedField)
505 If ocTarget.SubType = CTLGRIDCONTROL Then
506 .OnlyCurrentField = acAll
507 .GridControl = ocTarget._Shortcut
508 .Target = .GridControl
509 ofParentForm = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name))
510 If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
511 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
512 iCount = -1
514 Set vColumn = ocTarget.ControlModel.getByIndex(i)
515 Set vDataField = vColumn.BoundField ' examine field type
516 If Not IsNull(vDataField) Then
517 If _CheckColumnType(pvFindWhat, vDataField) Then
518 iCount = iCount + 1
519 ReDim Preserve vNames(0 To iCount)
520 vNames(iCount) = vColumn.Name
521 ReDim Preserve vIndexes(0 To iCount)
523 If vDataField.Name = oColumns.ElementNames(j) Then
524 vIndexes(iCount) = j + 1
525 Exit For
526 End If
527 Next j
528 End If
529 End If
530 Next i
532 ElseIf ocTarget._Type = OBJCONTROL Then ' Control within a grid tbc
533 If IsNull(ocTarget.ControlModel.BoundField) Then Goto Error_Target ' Control MUST be bound to a database record or query
534 ' BoundField is in ControlModel, thanks PASTIM !
535 .OnlyCurrentField = acCurrent
536 vParentGrid = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name))
537 If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target
538 .GridControl = vParentGrid._Shortcut
539 ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name))
540 If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola
541 If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
542 .Target = ocTarget._Shortcut
543 Set vDataField = ocTarget.ControlModel.BoundField
544 If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target
546 vNames(0) = ocTarget._Name
547 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
549 If vDataField.Name = oColumns.ElementNames(j) Then
551 Exit For
552 End If
553 Next j
554 End If
556 Case Else ' Determine focus
557 iCount = Application.Forms()._Count
558 If iCount = 0 Then Goto Error_ActiveForm
559 bFound = False
561 Set ofParentForm = Application.Forms(i)
562 If ofParentForm.Component.CurrentController.Frame.IsActive() Then
563 bFound = True
564 Exit For
565 End If
566 Next i
567 If Not bFound Then Goto Error_ActiveForm
568 If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm
569 iCount = ofParentForm.Controls().Count
570 bFound = False
572 Set ocGridControl = ofParentForm.Controls(i)
573 If ocGridControl.SubType = CTLGRIDCONTROL Then
574 bFound = True
575 Exit For
576 End If
577 Next i
578 If Not bFound Then Goto Error_NoGrid
579 .GridControl= ocGridControl._Shortcut
580 iFocus = -1
581 iFocus = ocGridControl.ControlView.getCurrentColumnPosition() ' Deprecated but no alternative found !!
583 If pvTargetedField = acAll Or iFocus < 0 Or iFocus >= ocGridControl.ControlModel.Count Then ' Has a control within the grid the focus ? NO
584 .OnlyCurrentField = acAll
585 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
586 iCount = -1
588 Set vColumn = ocGridControl.ControlModel.getByIndex(i)
589 Set vDataField = vColumn.BoundField ' examine field type
590 If Not IsNull(vDataField) Then
591 If _CheckColumnType(pvFindWhat, vDataField) Then
592 iCount = iCount + 1
593 ReDim Preserve vNames(0 To iCount)
594 vNames(iCount) = vColumn.Name
595 ReDim Preserve vIndexes(0 To iCount)
597 If vDataField.Name = oColumns.ElementNames(j) Then
598 vIndexes(iCount) = j + 1
599 Exit For
600 End If
601 Next j
602 End If
603 End If
604 Next i
606 Else ' Has a control within the grid the focus ? YES
607 .OnlyCurrentField = acCurrent
608 Set vColumn = ocGridControl.ControlModel.getByIndex(iFocus)
609 Set ocTarget = ocGridControl.Controls(vColumn.Name)
610 .Target = ocTarget._Shortcut
611 Set vDataField = ocTarget.ControlModel.BoundField
612 If IsNull(vDataField) Then Goto Error_Target ' Control MUST be bound to a database record or query
613 If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target
615 vNames(0) = ocTarget._Name
616 Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns
618 If vDataField.Name = oColumns.ElementNames(j) Then
620 Exit For
621 End If
622 Next j
623 End If
625 End Select
627 .Form = ofParentForm._Shortcut
628 .LastColumn = UBound(vNames)
629 .ColumnNames = vNames
630 .ResultSetIndex = vIndexes
631 If pvFindFirst Then
632 Select Case pvSearch
633 Case acDown, acSearchAll
634 ofParentForm.DatabaseForm.beforeFirst()
635 .LastRow = 0
636 Case acUp
637 ofParentForm.DatabaseForm.afterLast()
638 .LastRow = ofParentForm.DatabaseForm.RowCount + 1
639 End Select
640 Else
641 Select Case True
642 Case ofParentForm.DatabaseForm.isBeforeFirst And (pvSearch = acSearchAll Or pvSearch = acDown)
643 .LastRow = 0
644 Case ofParentForm.DatabaseForm.isAfterLast And pvSearch = acUp
645 ofParentForm.DatabaseForm.last() ' RowCount produces a wrong value as long as last record has not been reached
646 .LastRow = ofParentForm.DatabaseForm.RowCount + 1
647 Case Else
648 .LastRow = ofParentForm.DatabaseForm.getRow()
649 End Select
650 End If
652 .FindRecord = 1
654 End With
655 Set _A2B_.FindRecord = oFindRecord
656 FindRecord = DoCmd.Findnext()
658 Exit_Function:
660 Exit Function
661 Error_Function:
663 GoTo Exit_Function
664 Error_ActiveForm:
665 TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0)
666 Goto Exit_Function
667 Error_DatabaseForm:
669 Goto Exit_Function
670 Error_Target:
672 Goto Exit_Function
673 Error_NoGrid:
675 Goto Exit_Function
678 REM -----------------------------------------------------------------------------------------------------------------------
679 Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _
680 , ByVal Optional pvObjectName As Variant _
681 ) As Boolean
683 If _ErrorHandler() Then On Local Error Goto Error_Function
685 Utils._SetCalledSub(cstThisSub)
687 If IsMissing(pvObjectType) Then Call _TraceArguments()
688 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
689 Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _
690 ) Then Goto Exit_Function
691 If IsMissing(pvObjectName) Then
692 Select Case pvObjectType
693 Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
694 Case Else
695 End Select
696 pvObjectName = ""
697 Else
698 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
699 End If
701 Dim oWindow As Object
702 Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
703 If IsNull(oWindow.Frame) Then Goto Error_NotFound
704 GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible()
706 Exit_Function:
707 Utils._ResetCalledSub(cstThisSub)
708 Exit Function
709 Error_NotFound:
710 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
711 Goto Exit_Function
712 Error_Function:
713 TraceError(TRACEABORT, Err, cstThisSub, Erl)
714 GoTo Exit_Function
717 REM -----------------------------------------------------------------------------------------------------------------------
718 Public Function GoToControl(Optional ByVal pvControlName As variant) As Boolean
719 ' Set the focus on the named control on the active form.
720 ' Return False if the control does not exist or is disabled,
722 If _ErrorHandler() Then On Local Error Goto Error_Function
724 If IsMissing(pvControlName) Then Call _TraceArguments()
725 If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function
727 GoToControl = False
728 Dim oWindow As Object, ofForm As Object, ocControl As Object
729 Dim i As Integer, iCount As Integer
730 Set oWindow = _SelectWindow()
731 If oWindow.WindowType = acForm Then
732 Set ofForm = Application.Forms(oWindow._Name)
733 iCount = ofForm.Controls().Count
735 ocControl = ofForm.Controls(i)
736 If UCase(ocControl._Name) = UCase(pvControlName) Then
738 If ocControl.Enabled Then
739 ocControl.setFocus()
740 GoToControl = True
741 Exit For
742 End If
743 End If
744 End If
745 Next i
746 End If
748 Exit_Function:
750 Exit Function
751 Error_Function:
753 GoTo Exit_Function
756 REM -----------------------------------------------------------------------------------------------------------------------
757 Public Function GoToRecord(Optional ByVal pvObjectType As Variant _
758 , Optional ByVal pvObjectName As Variant _
759 , Optional ByVal pvRecord As Variant _
760 , Optional ByVal pvOffset As Variant _
761 ) As Boolean
763 'Move to record indicated by pvRecord in the object designated by pvObjectType (MUST BE acDataForm)
765 If _ErrorHandler() Then On Local Error Goto Error_Function
766 GoToRecord = False
769 Utils._SetCalledSub(cstThisSub)
770 If IsMissing(pvObjectName) Then pvObjectName = ""
771 If IsMissing(pvObjectType) Then pvObjectType = acActiveDataObject
772 ' If IsMissing(pvObjectType) Then
773 ' If pvObjectName <> "" Then pvObjectType = acDataForm Else pvObjectType = acActiveDataObject
774 ' End If
775 If IsMissing(pvRecord) Then pvRecord = acNext
776 If IsMissing(pvOffset) Then pvOffset = 1
777 If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _
778 , Array(acActiveDataObject, acDataForm, acDataQuery, acDataTable)) _
779 And Utils._CheckArgument(pvObjectName, 2, vbString) _
780 And Utils._CheckArgument(pvRecord, 3, Utils._AddNumeric() _
781 , Array(acFirst, acGoTo, acLast, acNewRec, acNext, acPrevious)) _
782 And Utils._CheckArgument(pvOffset, 4, Utils._AddNumeric()) _
783 ) Then Goto Exit_Function
784 If pvObjectType = acActiveDataObject And pvObjectName <> "" Then Goto Error_Target
787 Dim ofForm As Object, oGeneric As Object, oResultSet As Object, oWindow As Object
788 Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long
789 Dim sObjectName, iLengthName As Integer
790 Select Case pvObjectType
791 Case acActiveDataObject
792 Set oWindow = _SelectWindow()
793 With oWindow
794 Select Case .WindowType
795 Case acForm
796 Set oResultSet = _DatabaseForm(._Name, "")
797 Case acQuery, acTable
798 If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
800 Set oResultSet = .Frame.Controller.FormOperations.Cursor
801 Case Else ' Ignore action
802 Goto Exit_Function
803 End Select
804 End With
805 Case acDataForm
806 ' pvObjectName can be "myForm", "Forms!myForm", "Forms!myForm!mySubform" or "Forms!myForm!mySubform.Form"
807 sObjectName = UCase(pvObjectName)
808 iLengthName = Len(sObjectName)
809 Select Case True
810 Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" And Right(sObjectName, 5) = ".FORM"
811 Set ofForm = getObject(pvObjectName)
812 If ofForm._Type <> OBJSUBFORM Then Goto Error_Target
814 Set oGeneric = getObject(pvObjectName)
815 If oGeneric._Type = OBJFORM Or oGeneric._Type = OBJSUBFORM Then
816 Set ofForm = oGeneric
817 ElseIf oGeneric.SubType = CTLSUBFORM Then
818 Set ofForm = oGeneric.Form
819 Else Goto Error_Target
820 End If
821 Case sObjectName = ""
822 Call _TraceArguments()
823 Case Else
824 Set ofForm = Application.Forms(pvObjectName)
825 End Select
826 Set oResultSet = ofForm.DatabaseForm
827 Case acDataQuery
828 Set oWindow = _SelectWindow(acQuery, pvObjectName)
829 If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
831 Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor
832 Case acDataTable
833 Set oWindow = _SelectWindow(acTable, pvObjectName)
834 If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
835 Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor
836 Case Else
837 End Select
840 If oResultSet.IsNew Then
841 oResultSet.insertRow()
842 ElseIf oResultSet.IsModified Then
843 oResultSet.updateRow()
844 End If
846 lOffset = pvOffset
847 Select Case pvRecord
848 Case acFirst : GoToRecord = oResultSet.first()
849 Case acGoTo : GoToRecord = oResultSet.absolute(lOffset)
850 Case acLast : GoToRecord = oResultSet.last()
851 Case acNewRec
852 oResultSet.last() ' To simulate the behaviour in the UI
853 oResultSet.moveToInsertRow()
854 GoToRecord = True
855 Case acNext
856 If lOffset = 1 Then
857 GoToRecord = oResultSet.next()
858 Else
859 GoToRecord = oResultSet.relative(lOffset)
860 End If
861 Case acPrevious
862 If lOffset = 1 Then
863 GoToRecord = oResultSet.previous()
864 Else
865 GoToRecord = oResultSet.relative(- lOffset)
866 End If
867 End Select
869 Exit_Function:
870 Utils._ResetCalledSub(cstThisSub)
871 Exit Function
872 Error_Function:
873 TraceError(TRACEABORT, Err, cstThisSub, Erl)
874 GoTo Exit_Function
875 Error_Target:
877 Goto Exit_Function
878 Error_Offset:
880 Goto Exit_Function
881 Error_NotApplicable:
883 Goto Exit_Function
884 End Function ' GoToRecord
886 REM -----------------------------------------------------------------------------------------------------------------------
887 Public Function Maximize() As Boolean
888 ' Maximize the window having the focus
891 Dim oWindow As Object
892 Maximize = False
893 Set oWindow = _SelectWindow()
894 If Not IsNull(oWindow.Frame) Then
895 If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMaximized") Then oWindow.Frame.ContainerWindow.IsMaximized = True ' Ignored when <= OO3.2
896 Maximize = True
897 End If
900 Exit Function
903 REM -----------------------------------------------------------------------------------------------------------------------
904 Public Function Minimize() As Boolean
905 ' Maximize the form having the focus
908 Dim oWindow As Object
909 Minimize = False
910 Set oWindow = _SelectWindow()
911 If Not IsNull(oWindow.Frame) Then
912 If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMinimized") Then oWindow.Frame.ContainerWindow.IsMinimized = True
913 Minimize = True
914 End If
917 Exit Function
920 REM -----------------------------------------------------------------------------------------------------------------------
921 Public Function MoveSize(ByVal Optional pvLeft As Variant _
922 , ByVal Optional pvTop As Variant _
923 , ByVal Optional pvWidth As Variant _
924 , ByVal Optional pvHeight As Variant _
925 ) As Variant
926 ' Execute MoveSize action
927 If _ErrorHandler() Then On Local Error Goto Error_Function
929 MoveSize = False
930 If IsMissing(pvLeft) Then pvLeft = -1
931 If IsMissing(pvTop) Then pvTop = -1
932 If IsMissing(pvWidth) Then pvWidth = -1
933 If IsMissing(pvHeight) Then pvHeight = -1
934 If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function
935 If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function
936 If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function
937 If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function
939 Dim iArg As Integer, iWrong As Integer ' Check arguments values
940 iArg = 0
942 iArg = 4 : iWrong = pvHeight
944 iArg = 3 : iWrong = pvWidth
946 iArg = 2 : iWrong = pvTop
948 iArg = 1 : iWrong = pvLeft
949 End If
952 Goto Exit_Function
953 End If
955 Dim iPosSize As Integer
956 iPosSize = 0
962 Dim oWindow As Object
963 Set oWindow = _SelectWindow()
964 With oWindow
965 If Not IsNull(.Frame) Then
966 If Utils._hasUNOProperty(.Frame.ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2
967 .Frame.ContainerWindow.IsMaximized = False
968 .Frame.ContainerWindow.IsMinimized = False
969 End If
970 .Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize)
971 MoveSize = True
972 End If
973 End With
975 Exit_Function:
977 Exit Function
978 Error_Function:
980 GoTo Exit_Function
983 REM -----------------------------------------------------------------------------------------------------------------------
984 Public Function OpenForm(Optional ByVal pvFormName As Variant _
985 , Optional ByVal pvView As Variant _
986 , Optional ByVal pvFilterName As Variant _
987 , Optional ByVal pvWhereCondition As Variant _
988 , Optional ByVal pvDataMode As Variant _
989 , Optional ByVal pvWindowMode As Variant _
990 , Optional ByVal pvOpenArgs As Variant _
991 ) As Variant
993 If _ErrorHandler() Then On Local Error Goto Error_Function
996 If IsMissing(pvFormName) Then Call _TraceArguments()
997 If IsMissing(pvView) Then pvView = acNormal
998 If IsMissing(pvFilterName) Then pvFilterName = ""
999 If IsMissing(pvWhereCondition) Then pvWhereCondition = ""
1000 If IsMissing(pvDataMode) Then pvDataMode = acFormPropertySettings
1001 If IsMissing(pvWindowMode) Then pvWindowMode = acWindowNormal
1002 If IsMissing(pvOpenArgs) Then pvOpenArgs = ""
1003 Set OpenForm = Nothing
1004 If Not (Utils._CheckArgument(pvFormName, 1, vbString) _
1005 And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acNormal, acPreview, acDesign)) _
1006 And Utils._CheckArgument(pvFilterName, 3, vbString) _
1007 And Utils._CheckArgument(pvWhereCondition, 4, vbString) _
1008 And Utils._CheckArgument(pvDataMode, 5, Utils._AddNumeric(), Array(acFormAdd, acFormEdit, acFormPropertySettings, acFormReadOnly)) _
1009 And Utils._CheckArgument(pvWindowMode, 6, Utils._AddNumeric(), Array(acDialog, acHidden, acIcon, acWindowNormal)) _
1010 ) Then Goto Exit_Function
1012 Dim ofForm As Object, sWarning As String
1013 Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object
1015 Set oDatabase = Application._CurrentDb()
1016 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1018 Set ofForm = Application.AllForms(pvFormName)
1019 If ofForm.IsLoaded Then
1023 Set OpenForm = ofForm
1024 Goto Exit_Function
1025 End If
1026 ' Open the form
1027 Select Case pvView
1028 Case acNormal, acPreview: bOpenMode = False
1029 Case acDesign : bOpenMode = True
1030 End Select
1031 Set oController = oDatabase.Document.CurrentController
1032 Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode)
1034 ' Apply the filters (FilterName) AND (WhereCondition)
1035 Dim sFilter As String, oForm As Object, oFormsCollection As Object
1037 sFilter = ""
1039 sFilter = pvFilterName & pvWhereCondition
1040 Else
1041 sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")"
1042 End If
1043 Set oFormsCollection = oOpenForm.DrawPage.Forms
1048 ElseIf oFormsCollection.hasByName(ofForm._Name) Then
1049 Set oForm = oFormsCollection.getByName(ofForm._Name)
1050 Else
1051 Goto Trace_Error
1052 End If
1053 If sFilter <> "" Then
1054 oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter)
1055 oForm.ApplyFilter = True
1056 oForm.reload()
1057 ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed
1058 oForm.Filter = ""
1059 oForm.ApplyFilter = False
1060 oForm.reload()
1061 End If
1063 'Housekeeping
1064 Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open
1065 With ofForm
1066 Select Case pvDataMode
1067 Case acFormAdd
1068 .AllowAdditions = True
1069 .AllowDeletions = False
1070 .AllowEdits = False
1071 Case acFormEdit
1072 .AllowAdditions = True
1073 .AllowDeletions = True
1074 .AllowEdits = True
1075 Case acFormReadOnly
1076 .AllowAdditions = False
1077 .AllowDeletions = False
1078 .AllowEdits = False
1079 Case acFormPropertySettings
1080 End Select
1081 .Visible = ( pvWindowMode <> acHidden )
1082 ._OpenArgs = pvOpenArgs
1083 'To avoid AOO 3,4 bug See http://user.services.openoffice.org/en/forum/viewtopic.php?f=13&t=53751
1084 .Component.CurrentController.ViewSettings.ShowOnlineLayout = True
1085 End With
1087 Set OpenForm = ofForm
1089 Exit_Function:
1091 Set ofForm = Nothing
1092 Set oOpenForm = Nothing
1093 Exit Function
1094 Error_Function:
1096 Set OpenForm = Nothing
1097 GoTo Exit_Function
1098 Error_NotApplicable:
1100 Goto Exit_Function
1101 Trace_Error:
1102 TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName)
1103 Set OpenForm = Nothing
1104 Goto Exit_Function
1107 REM -----------------------------------------------------------------------------------------------------------------------
1108 Public Function OpenQuery(Optional ByVal pvQueryName As Variant _
1109 , Optional ByVal pvView As Variant _
1110 , Optional ByVal pvDataMode As Variant _
1111 ) As Boolean
1113 If _ErrorHandler() Then On Local Error Goto Error_Function
1116 If IsMissing(pvQueryName) Then Call _TraceArguments()
1117 If IsMissing(pvView) Then pvView = acViewNormal
1118 If IsMissing(pvDataMode) Then pvDataMode = acEdit
1121 Exit_Function:
1123 Exit Function
1124 Error_Function:
1126 GoTo Exit_Function
1127 End Function ' OpenQuery
1129 REM -----------------------------------------------------------------------------------------------------------------------
1130 Public Function OpenReport(Optional ByVal pvReportName As Variant _
1131 , Optional ByVal pvView As Variant _
1132 , Optional ByVal pvDataMode As Variant _
1133 ) As Boolean
1135 If _ErrorHandler() Then On Local Error Goto Error_Function
1138 If IsMissing(pvReportName) Then Call _TraceArguments()
1139 If IsMissing(pvView) Then pvView = acViewNormal
1140 If IsMissing(pvDataMode) Then pvDataMode = acEdit
1143 Exit_Function:
1145 Exit Function
1146 Error_Function:
1148 GoTo Exit_Function
1149 End Function ' OpenReport
1151 REM -----------------------------------------------------------------------------------------------------------------------
1152 Public Function OpenSQL(Optional ByVal pvSQL As Variant _
1153 , Optional ByVal pvOption As Variant _
1154 ) As Boolean
1155 ' Return True if the execution of the SQL statement was successful
1156 ' SQL must contain a SELECT query
1157 ' pvOption can force pass through mode
1159 If _ErrorHandler() Then On Local Error Goto Error_Function
1163 OpenSQL = False
1164 If IsMissing(pvSQL) Then Call _TraceArguments()
1165 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
1166 Const cstNull = -1
1167 If IsMissing(pvOption) Then
1168 pvOption = cstNull
1169 Else
1170 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
1171 End If
1173 OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption)
1175 Exit_Function:
1177 Exit Function
1178 Error_Function:
1180 GoTo Exit_Function
1183 REM -----------------------------------------------------------------------------------------------------------------------
1184 Public Function OpenTable(Optional ByVal pvTableName As Variant _
1185 , Optional ByVal pvView As Variant _
1186 , Optional ByVal pvDataMode As Variant _
1187 ) As Boolean
1189 If _ErrorHandler() Then On Local Error Goto Error_Function
1192 If IsMissing(pvTableName) Then Call _TraceArguments()
1193 If IsMissing(pvView) Then pvView = acViewNormal
1194 If IsMissing(pvDataMode) Then pvDataMode = acEdit
1197 Exit_Function:
1199 Exit Function
1200 Error_Function:
1202 GoTo Exit_Function
1203 End Function ' OpenTable
1205 REM -----------------------------------------------------------------------------------------------------------------------
1206 Public Function OutputTo(ByVal pvObjectType As Variant _
1207 , ByVal Optional pvObjectName As Variant _
1208 , ByVal Optional pvOutputFormat As Variant _
1209 , ByVal Optional pvOutputFile As Variant _
1210 , ByVal Optional pvAutoStart As Variant _
1211 , ByVal Optional pvTemplateFile As Variant _
1212 , ByVal Optional pvEncoding As Variant _
1213 ) As Boolean
1214 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms
1216 If _ErrorHandler() Then On Local Error Goto Error_Function
1218 OutputTo = False
1220 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), acSendForm) Then Goto Exit_Function
1221 If IsMissing(pvObjectName) Then pvObjectName = ""
1222 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
1223 If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
1224 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
1225 If pvOutputFormat <> "" Then
1226 If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
1227 UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _
1230 End If
1231 If IsMissing(pvOutputFile) Then pvOutputFile = ""
1232 If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
1233 If IsMissing(pvAutoStart) Then pvAutoStart = False
1234 If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
1235 If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
1237 If IsMissing(pvEncoding) Then pvEncoding = ""
1240 Dim vWindow As Variant, sOutputFile As String, ofForm As Object, i As Integer, bFound As Boolean
1241 'Find applicable form
1242 If pvObjectName = "" Then
1243 vWindow = _SelectWindow()
1244 If vWindow.WindowType <> acSendForm Then Goto Error_Action
1245 Set ofForm = Application.Forms(vWindow._Name)
1246 Else
1247 bFound = False
1249 Set ofForm = Application.Forms(i)
1250 If UCase(ofForm._Name) = UCase(pvObjectName) Then
1251 bFound = True
1252 Exit For
1253 End If
1254 Next i
1255 If Not bFound Then Goto Error_NotFound
1256 End If
1258 'Determine format and parameters
1259 Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport As Object, sSuffix As String
1260 If pvOutputFormat = "" Then
1261 sOutputFormat = _PromptFormat() ' Prompt user for format
1262 If sOutputFormat = "" Then Goto Exit_Function
1263 Else
1264 sOutputFormat = UCase(pvOutputFormat)
1265 End If
1266 Select Case sOutputFormat
1268 sFilter = acFormatPDF
1269 oFilterData = Array( _
1271 )
1274 sFilter = acFormatDOC
1275 oFilterData = Array()
1278 sFilter = acFormatODT
1279 oFilterData = Array()
1282 sFilter = acFormatHTML
1283 oFilterData = Array()
1285 End Select
1286 oExport = Array( _
1290 )
1292 'Determine output file
1294 sOutputFile = _PromptFilePicker(sSuffix)
1295 If sOutputFile = "" Then Goto Exit_Function
1296 Else
1297 sOutputFile = pvOutputFile
1298 End If
1299 sOutputFile = ConvertToURL(sOutputFile)
1301 'Create file
1302 On Local Error Goto Error_File
1303 ofForm.Component.storeToURL(sOutputFile, oExport)
1304 On Local Error Goto Error_Function
1306 'Launch application, if requested
1307 If pvAutoStart Then Call _ShellExecute(sOutputFile)
1309 OutputTo = True
1311 Exit_Function:
1313 Exit Function
1314 Error_NotFound:
1315 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1316 Goto Exit_Function
1317 Error_Action:
1318 TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
1319 Goto Exit_Function
1320 Error_Function:
1322 GoTo Exit_Function
1323 Error_File:
1324 TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
1325 GoTo Exit_Function
1328 REM -----------------------------------------------------------------------------------------------------------------------
1329 Public Function Quit(Optional ByVal pvSave As Variant) As Variant
1330 ' Quit the application
1333 If _ErrorHandler() Then On Local Error Goto Error_Function
1335 Utils._SetCalledSub(cstThisSub)
1337 If IsMissing(pvSave) Then pvSave = acQuitSaveAll
1338 If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _
1339 Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _
1340 ) Then Goto Exit_Function
1342 Dim oDatabase As Object, oDoc As Object
1343 Set oDatabase = Application._CurrentDb()
1344 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1345 If Not IsNull(oDatabase) Then
1346 Set oDoc = oDatabase.Document
1347 Select Case pvSave
1348 Case acQuitPrompt
1349 If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function
1350 Case acQuitSaveNone
1351 oDoc.setModified(False)
1352 Case Else
1353 End Select
1355 If (oDoc.isModified) Then
1356 If (oDoc.hasLocation AND (Not oDoc.isReadOnly)) Then
1357 oDoc.store()
1358 End If
1359 End If
1360 oDoc.close(true)
1361 Else
1362 oDoc.dispose()
1363 End If
1364 End If
1366 Exit_Function:
1367 Utils._ResetCalledSub(cstThisSub)
1368 Set oDatabase = Nothing
1369 Set oDoc = Nothing
1370 Exit Function
1371 Error_Function:
1372 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
1373 Set OpenForm = Nothing
1374 GoTo Exit_Function
1375 Error_NotApplicable:
1377 Goto Exit_Function
1380 REM -----------------------------------------------------------------------------------------------------------------------
1381 Public Sub RunApp(Optional ByVal pvCommandLine As Variant)
1382 ' Convert to URL and execute the Command Line
1384 If _ErrorHandler() Then On Local Error Goto Error_Sub
1388 If IsMissing(pvCommandLine) Then Call _TraceArguments()
1389 If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub
1391 _ShellExecute(ConvertToURL(pvCommandLine))
1393 Exit_Sub:
1395 Exit Sub
1396 Error_Sub:
1398 GoTo Exit_Sub
1401 REM -----------------------------------------------------------------------------------------------------------------------
1402 Public Function RunCommand(Optional pvCommand As Variant, Optional pbReturnCommand As Boolean) As Variant
1403 ' Execute command via DispatchHelper
1404 ' pbReturnCommand = internal parameter to only return the exact command string (always absent if uno prefix present in pvCommand)
1406 If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort
1408 Utils._SetCalledSub(cstThisSub)
1410 Dim iVBACommand As Integer, sOOCommand As String, sDispatch As String
1411 If IsMissing(pvCommand) Then Call _TraceArguments()
1412 If Not ( Utils._CheckArgument(pvCommand, 1, Utils._AddNumeric(vbString)) ) Then Goto Exit_Function
1413 If IsMissing(pbReturnCommand) Then pbReturnCommand = False
1415 RunCommand = True
1418 If VarType(pvCommand) = vbString Then
1419 sOOCommand = pvCommand
1420 iVBACommand = -1
1421 If _IsLeft(sOOCommand, cstUnoPrefix) Then
1422 Call _DispatchCommand(sOOCommand)
1423 Goto Exit_Function
1424 End If
1425 Else
1426 sOOCommand = ""
1427 iVBACommand = pvCommand
1428 End If
1430 Select Case True
1431 Case iVBACommand = acCmdAboutMicrosoftAccess Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
1432 Case iVBACommand = acCmdAboutOpenOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
1433 Case iVBACommand = acCmdAboutLibreOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About"
1437 Case UCase(sOOCommand) = "AUTOCONTROLFOCUS" : sDispatch = "AutoControlFocus"
1439 Case UCase(sOOCommand) = "AUTOPILOTADDRESSDATASOURCE" : sDispatch = "AutoPilotAddressDataSource"
1441 Case iVBACommand = acCmdVisualBasicEditor Or UCase(sOOCommand) = "BASICIDEAPPEAR" : sDispatch = "BasicIDEAppear"
1443 Case iVBACommand = acCmdBringToFront Or UCase(sOOCommand) = "BRINGTOFRONT" : sDispatch = "BringToFront"
1446 Case iVBACommand = acCmdClose Or UCase(sOOCommand) = "CLOSEDOC" : sDispatch = "CloseDoc"
1448 Case iVBACommand = acCmdToolbarsCustomize Or UCase(sOOCommand) = "CONFIGUREDIALOG" : sDispatch = "ConfigureDialog"
1449 Case UCase(sOOCommand) = "CONTROLPROPERTIES" : sDispatch = "ControlProperties"
1450 Case iVBACommand = acCmdChangeToCommandButton Or UCase(sOOCommand) = "CONVERTTOBUTTON" : sDispatch = "ConvertToButton"
1451 Case iVBACommand = acCmdChangeToCheckBox Or UCase(sOOCommand) = "CONVERTTOCHECKBOX" : sDispatch = "ConvertToCheckBox"
1452 Case iVBACommand = acCmdChangeToComboBox Or UCase(sOOCommand) = "CONVERTTOCOMBO" : sDispatch = "ConvertToCombo"
1453 Case UCase(sOOCommand) = "CONVERTTOCURRENCY" : sDispatch = "ConvertToCurrency"
1455 Case iVBACommand = acCmdChangeToTextBox Or UCase(sOOCommand) = "CONVERTTOEDIT" : sDispatch = "ConvertToEdit"
1456 Case UCase(sOOCommand) = "CONVERTTOFILECONTROL" : sDispatch = "ConvertToFileControl"
1457 Case iVBACommand = acCmdChangeToLabel Or UCase(sOOCommand) = "CONVERTTOFIXED" : sDispatch = "ConvertToFixed"
1458 Case UCase(sOOCommand) = "CONVERTTOFORMATTED" : sDispatch = "ConvertToFormatted"
1460 Case UCase(sOOCommand) = "CONVERTTOIMAGEBTN" : sDispatch = "ConvertToImageBtn"
1461 Case iVBACommand = acCmdChangeToImage Or UCase(sOOCommand) = "CONVERTTOIMAGECONTROL" : sDispatch = "ConvertToImageControl"
1462 Case iVBACommand = acCmdChangeToListBox Or UCase(sOOCommand) = "CONVERTTOLIST" : sDispatch = "ConvertToList"
1463 Case UCase(sOOCommand) = "CONVERTTONAVIGATIONBAR" : sDispatch = "ConvertToNavigationBar"
1464 Case UCase(sOOCommand) = "CONVERTTONUMERIC" : sDispatch = "ConvertToNumeric"
1465 Case UCase(sOOCommand) = "CONVERTTOPATTERN" : sDispatch = "ConvertToPattern"
1466 Case iVBACommand = acCmdChangeToOptionButton Or UCase(sOOCommand) = "CONVERTTORADIO" : sDispatch = "ConvertToRadio"
1467 Case UCase(sOOCommand) = "CONVERTTOSCROLLBAR" : sDispatch = "ConvertToScrollBar"
1468 Case UCase(sOOCommand) = "CONVERTTOSPINBUTTON" : sDispatch = "ConvertToSpinButton"
1470 Case iVBACommand = acCmdCopy Or UCase(sOOCommand) = "COPY" : sDispatch = "Copy"
1472 Case iVBACommand = acCmdCut Or UCase(sOOCommand) = "CUT" : sDispatch = "Cut"
1474 Case iVBACommand = acCmdCreateRelationship Or UCase(sOOCommand) = "DBADDRELATION " : sDispatch = "DBAddRelation "
1475 Case UCase(sOOCommand) = "DBCONVERTTOVIEW " : sDispatch = "DBConvertToView "
1476 Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DBDELETE " : sDispatch = "DBDelete "
1478 Case UCase(sOOCommand) = "DBDSADVANCEDSETTINGS " : sDispatch = "DBDSAdvancedSettings "
1479 Case UCase(sOOCommand) = "DBDSCONNECTIONTYPE " : sDispatch = "DBDSConnectionType "
1480 Case iVBACommand = acCmdDatabaseProperties Or UCase(sOOCommand) = "DBDSPROPERTIES " : sDispatch = "DBDSProperties "
1482 Case iVBACommand = acCmdSQLView Or UCase(sOOCommand) = "DBEDITSQLVIEW " : sDispatch = "DBEditSqlView "
1483 Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBFORMDELETE " : sDispatch = "DBFormDelete "
1484 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBFORMEDIT " : sDispatch = "DBFormEdit "
1485 Case iVBACommand = acCmdFormView Or UCase(sOOCommand) = "DBFORMOPEN " : sDispatch = "DBFormOpen "
1487 Case iVBACommand = acCmdNewObjectForm Or UCase(sOOCommand) = "DBNEWFORM " : sDispatch = "DBNewForm "
1488 Case UCase(sOOCommand) = "DBNEWFORMAUTOPILOT " : sDispatch = "DBNewFormAutoPilot "
1490 Case UCase(sOOCommand) = "DBNEWQUERYAUTOPILOT " : sDispatch = "DBNewQueryAutoPilot "
1493 Case UCase(sOOCommand) = "DBNEWREPORTAUTOPILOT " : sDispatch = "DBNewReportAutoPilot "
1494 Case iVBACommand = acCmdNewObjectTable Or UCase(sOOCommand) = "DBNEWTABLE " : sDispatch = "DBNewTable "
1495 Case UCase(sOOCommand) = "DBNEWTABLEAUTOPILOT " : sDispatch = "DBNewTableAutoPilot "
1496 Case iVBACommand = acCmdNewObjectView Or UCase(sOOCommand) = "DBNEWVIEW " : sDispatch = "DBNewView "
1498 Case iVBACommand = acCmdOpenDatabase Or UCase(sOOCommand) = "DBOPEN " : sDispatch = "DBOpen "
1499 Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBQUERYDELETE " : sDispatch = "DBQueryDelete "
1500 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBQUERYEDIT " : sDispatch = "DBQueryEdit "
1501 Case iVBACommand = acCmdNewObjectQuery Or UCase(sOOCommand) = "DBQUERYOPEN " : sDispatch = "DBQueryOpen "
1503 Case UCase(sOOCommand) = "DBREFRESHTABLES " : sDispatch = "DBRefreshTables "
1504 Case iVBACommand = acCmdShowAllRelationships Or UCase(sOOCommand) = "DBRELATIONDESIGN " : sDispatch = "DBRelationDesign "
1506 Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBREPORTDELETE " : sDispatch = "DBReportDelete "
1507 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBREPORTEDIT " : sDispatch = "DBReportEdit "
1508 Case iVBACommand = acCmdNewObjectReport Or UCase(sOOCommand) = "DBREPORTOPEN " : sDispatch = "DBReportOpen "
1510 Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "DBSELECTALL " : sDispatch = "DBSelectAll "
1511 Case UCase(sOOCommand) = "DBSHOWDOCINFOPREVIEW " : sDispatch = "DBShowDocInfoPreview "
1512 Case UCase(sOOCommand) = "DBSHOWDOCPREVIEW " : sDispatch = "DBShowDocPreview "
1513 Case iVBACommand = acCmdRemoveTable Or UCase(sOOCommand) = "DBTABLEDELETE " : sDispatch = "DBTableDelete "
1514 Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBTABLEEDIT " : sDispatch = "DBTableEdit "
1516 Case iVBACommand = acCmdOpenTable Or UCase(sOOCommand) = "DBTABLEOPEN " : sDispatch = "DBTableOpen "
1517 Case iVBACommand = acCmdRename Or UCase(sOOCommand) = "DBTABLERENAME " : sDispatch = "DBTableRename "
1523 Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DELETE" : sDispatch = "Delete"
1524 Case iVBACommand = acCmdDeleteRecord Or UCase(sOOCommand) = "DELETERECORD" : sDispatch = "DeleteRecord"
1532 Case iVBACommand = acCmdApplyFilterSort Or UCase(sOOCommand) = "FORMFILTERED" : sDispatch = "FormFiltered"
1533 Case UCase(sOOCommand) = "FORMFILTEREXECUTE" : sDispatch = "FormFilterExecute"
1535 Case UCase(sOOCommand) = "FORMFILTERNAVIGATOR" : sDispatch = "FormFilterNavigator"
1540 Case iVBACommand = acCmdSnapToGrid Or UCase(sOOCommand) = "GRIDUSE" : sDispatch = "GridUse"
1541 Case iVBACommand = acCmdViewGrid Or UCase(sOOCommand) = "GRIDVISIBLE" : sDispatch = "GridVisible"
1545 Case iVBACommand = acCmdInsertHyperlink Or UCase(sOOCommand) = "HYPERLINKDIALOG" : sDispatch = "HyperlinkDialog"
1549 Case iVBACommand = acCmdMaximumRecords Or UCase(sOOCommand) = "LASTRECORD" : sDispatch = "LastRecord"
1555 Case iVBACommand = acCmdObjectBrowser Or UCase(sOOCommand) = "NAVIGATOR" : sDispatch = "Navigator"
1561 Case UCase(sOOCommand) = "OPTIONSTREEDIALOG" : sDispatch = "OptionsTreeDialog"
1564 Case iVBACommand = acCmdPaste Or UCase(sOOCommand) = "PASTE" : sDispatch = "Paste"
1565 Case iVBACommand = acCmdPasteSpecial Or UCase(sOOCommand) = "PASTESPECIAL " : sDispatch = "PasteSpecial "
1568 Case iVBACommand = acCmdPrint Or UCase(sOOCommand) = "PRINT" : sDispatch = "Print"
1571 Case iVBACommand = acCmdPrintPreview Or UCase(sOOCommand) = "PRINTPREVIEW" : sDispatch = "PrintPreview"
1575 Case iVBACommand = acCmdSaveRecord Or UCase(sOOCommand) = "RECSAVE" : sDispatch = "RecSave"
1576 Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "RECSEARCH" : sDispatch = "RecSearch"
1577 Case iVBACommand = acCmdUndo Or UCase(sOOCommand) = "RECUNDO" : sDispatch = "RecUndo"
1578 Case iVBACommand = acCmdRefresh Or UCase(sOOCommand) = "REFRESH" : sDispatch = "Refresh"
1580 Case iVBACommand = acCmdRemoveFilterSort Or UCase(sOOCommand) = "REMOVEFILTERSORT" : sDispatch = "RemoveFilterSort"
1581 Case iVBACommand = acCmdRunMacro Or UCase(sOOCommand) = "RUNMACRO" : sDispatch = "RunMacro"
1582 Case iVBACommand = acCmdSave Or UCase(sOOCommand) = "SAVE" : sDispatch = "Save"
1584 Case iVBACommand = acCmdSaveAs Or UCase(sOOCommand) = "SAVEAS" : sDispatch = "SaveAs"
1588 Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "SEARCHDIALOG" : sDispatch = "SearchDialog"
1589 Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll"
1590 Case iVBACommand = acCmdSelectAllRecords Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll"
1591 Case iVBACommand = acCmdSendToBack Or UCase(sOOCommand) = "SENDTOBACK" : sDispatch = "SendToBack"
1594 Case iVBACommand = acCmdSortDescending Or UCase(sOOCommand) = "SORTDOWN" : sDispatch = "SortDown"
1595 Case iVBACommand = acCmdSortAscending Or UCase(sOOCommand) = "SORTUP" : sDispatch = "Sortup"
1597 Case UCase(sOOCommand) = "STATUSBARVISIBLE" : sDispatch = "StatusBarVisible"
1598 Case UCase(sOOCommand) = "SWITCHCONTROLDESIGNMODE" : sDispatch = "SwitchControlDesignMode"
1599 Case iVBACommand = acCmdTabOrder Or UCase(sOOCommand) = "TABDIALOG" : sDispatch = "TabDialog"
1602 Case UCase(sOOCommand) = "VIEWDATASOURCEBROWSER" : sDispatch = "ViewDataSourceBrowser"
1603 Case iVBACommand = acCmdDatasheetView Or UCase(sOOCommand) = "VIEWFORMASGRID" : sDispatch = "ViewFormAsGrid"
1604 Case iVBACommand = acCmdZoomSelection Or UCase(sOOCommand) = "ZOOM" : sDispatch = "Zoom"
1605 Case Else
1607 sDispatch = pvCommand
1608 End Select
1610 If pbReturnCommand Then RunCommand = cstUnoPrefix & sDispatch Else Call _DispatchCommand(cstUnoPrefix & sDispatch)
1612 Exit_Function:
1613 Utils._ResetCalledSub(cstThisSub)
1614 Exit Function
1615 Error_Function:
1616 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
1617 GoTo Exit_Function
1620 REM -----------------------------------------------------------------------------------------------------------------------
1621 Public Function RunSQL(Optional ByVal pvSQL As Variant _
1622 , Optional ByVal pvOption As Variant _
1623 ) As Boolean
1624 ' Return True if the execution of the SQL statement was successful
1625 ' SQL must contain an ACTION query
1627 If _ErrorHandler() Then On Local Error Goto Error_Function
1631 RunSQL = False
1632 If IsMissing(pvSQL) Then Call _TraceArguments()
1633 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
1634 Const cstNull = -1
1635 If IsMissing(pvOption) Then
1636 pvOption = cstNull
1637 Else
1638 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
1639 End If
1641 RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption)
1643 Exit_Function:
1645 Exit Function
1646 Error_Function:
1648 GoTo Exit_Function
1651 REM -----------------------------------------------------------------------------------------------------------------------
1652 Public Function SelectObject( ByVal Optional pvObjectType As Variant _
1653 , ByVal Optional pvObjectName As Variant _
1654 , ByVal Optional pvInDatabaseWindow As Variant _
1655 ) As Boolean
1657 If _ErrorHandler() Then On Local Error Goto Error_Function
1659 Utils._SetCalledSub(cstThisSub)
1661 If IsMissing(pvObjectType) Then Call _TraceArguments()
1662 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
1663 Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _
1664 ) Then Goto Exit_Function
1665 If IsMissing(pvObjectName) Then
1666 Select Case pvObjectType
1667 Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
1668 Case Else
1669 End Select
1670 pvObjectName = ""
1671 Else
1672 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
1673 End If
1674 If Not IsMissing(pvInDatabaseWindow) Then
1675 If Not Utils._CheckArgument(pvInDatabaseWindow, 3, vbBoolean, False) Then Goto Exit_Function
1676 End If
1678 Dim oWindow As Object
1679 Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
1680 If IsNull(oWindow.Frame) Then Goto Error_NotFound
1681 With oWindow.Frame.ContainerWindow
1682 If .isVisible() = False Then .setVisible(True)
1683 .IsMinimized = False
1684 .setFocus()
1685 .setEnable(True) ' Added to try to bypass desynchro issue in Linux
1686 .toFront() ' Added to force window change in Linux
1687 End With
1689 Exit_Function:
1690 Utils._ResetCalledSub(cstThisSub)
1691 Exit Function
1692 Error_NotFound:
1693 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1694 Goto Exit_Function
1695 Error_Function:
1696 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1697 GoTo Exit_Function
1700 REM -----------------------------------------------------------------------------------------------------------------------
1701 Public Function SendObject(ByVal Optional pvObjectType As Variant _
1702 , ByVal Optional pvObjectName As Variant _
1703 , ByVal Optional pvOutputFormat As Variant _
1704 , ByVal Optional pvTo As Variant _
1705 , ByVal Optional pvCc As Variant _
1706 , ByVal Optional pvBcc As Variant _
1707 , ByVal Optional pvSubject As Variant _
1708 , ByVal Optional pvMessageText As Variant _
1709 , ByVal Optional pvEditMessage As Variant _
1710 , ByVal Optional pvTemplateFile As Variant _
1711 ) As Boolean
1712 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms
1713 'To be prepared: acFormatCSV and acFormatODS for tables/queries ?
1714 If _ErrorHandler() Then On Local Error Goto Error_Function
1716 SendObject = False
1718 If IsMissing(pvObjectType) Then pvObjectType = acSendNoObject
1719 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acSendNoObject, acSendForm)) Then Goto Exit_Function
1720 If IsMissing(pvObjectName) Then pvObjectName = ""
1721 If Not Utils._CheckArgument(pvObjectName, 2,vbString) Then Goto Exit_Function
1722 If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
1723 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
1724 If pvOutputFormat <> "" Then
1725 If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
1726 UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _
1729 End If
1730 If IsMissing(pvTo) Then pvTo = ""
1731 If Not Utils._CheckArgument(pvTo, 4, vbString) Then Goto Exit_Function
1732 If IsMissing(pvCc) Then pvCc = ""
1733 If Not Utils._CheckArgument(pvCc, 5, vbString) Then Goto Exit_Function
1734 If IsMissing(pvBcc) Then pvBcc = ""
1735 If Not Utils._CheckArgument(pvBcc, 6, vbString) Then Goto Exit_Function
1736 If IsMissing(pvSubject) Then pvSubject = ""
1737 If Not Utils._CheckArgument(pvSubject, 7, vbString) Then Goto Exit_Function
1738 If IsMissing(pvMessageText) Then pvMessageText = ""
1739 If Not Utils._CheckArgument(pvMessageText, 8, vbString) Then Goto Exit_Function
1740 If IsMissing(pvEditMessage) Then pvEditMessage = True
1741 If Not Utils._CheckArgument(pvEditMessage, 9, vbBoolean) Then Goto Exit_Function
1742 If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
1745 Dim vTo() As Variant, vCc() As Variant, vBcc() As Variant, oWindow As Object
1746 Dim sDirectory As String, sOutputFile As String, sSuffix As String, sOutputFormat As String
1748 If pvTo <> "" Then vTo() = Split(pvTo, cstSemiColon) Else vTo() = Array()
1749 If pvCc <> "" Then vCc() = Split(pvCc, cstSemiColon) Else vCc() = Array()
1750 If pvBcc <> "" Then vBcc() = Split(pvBcc, cstSemiColon) Else vBcc() = Array()
1751 Select Case True
1752 Case pvObjectType = acSendNoObject And pvObjectName = ""
1753 SendObject = _SendWithoutAttachment(vTo, vCc, vBcc, pvSubject, pvMessageText)
1754 Case Else
1755 If pvObjectType = acSendNoObject And pvObjectName <> "" Then
1756 If Not FileExists(pvObjectName) Then Goto Error_File
1757 sOutputFile = pvObjectName
1758 Else ' OutputFile has to be created
1760 oWindow = _SelectWindow()
1761 If oWindow.WindowType <> acSendForm Then Goto Error_Action
1762 pvObjectType = acSendForm
1763 pvObjectName = oWindow._Name
1764 End If
1765 sDirectory = _getTempDirectoryURL()
1766 If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/"
1767 If pvOutputFormat = "" Then
1768 sOutputFormat = _PromptFormat() ' Prompt user for format
1769 If sOutputFormat = "" Then Goto Exit_Function
1770 Else
1771 sOutputFormat = UCase(pvOutputFormat)
1772 End If
1773 Select Case sOutputFormat
1778 End Select
1780 If Not OutputTo(pvObjectType, pvObjectName, sOutputFormat, sOutputFile, False) Then Goto Exit_Function
1781 End If
1782 SendObject = _SendWithAttachment(vTo, vCc, vBcc, pvSubject, Array(sOutputFile), pvMessageText, pvEditMessage)
1783 End Select
1785 Exit_Function:
1787 Exit Function
1788 Error_NotFound:
1789 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1790 Goto Exit_Function
1791 Error_Function:
1793 GoTo Exit_Function
1794 Error_Action:
1795 TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0)
1796 Goto Exit_Function
1797 Error_File:
1798 TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , pvObjectName)
1799 Goto Exit_Function
1802 REM -----------------------------------------------------------------------------------------------------------------------
1803 Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _
1804 , ByVal Optional pvObjectName As Variant _
1805 , ByVal Optional pvHidden As Variant _
1806 ) As Boolean
1808 If _ErrorHandler() Then On Local Error Goto Error_Function
1809 SetHiddenAttribute = False
1811 Utils._SetCalledSub(cstThisSub)
1813 If IsMissing(pvObjectType) Then Call _TraceArguments()
1814 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _
1815 Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _
1816 ) Then Goto Exit_Function
1817 If IsMissing(pvObjectName) Then
1818 Select Case pvObjectType
1819 Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments()
1820 Case Else
1821 End Select
1822 pvObjectName = ""
1823 Else
1824 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
1825 End If
1826 If IsMissing(pvHidden) Then
1827 pvHidden = True
1828 Else
1829 If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function
1830 End If
1832 Dim oWindow As Object
1833 Set oWindow = _SelectWindow(pvObjectType, pvObjectName)
1834 If IsNull(oWindow.Frame) Then Goto Error_NotFound
1835 oWindow.Frame.ContainerWindow.setVisible(Not pvHidden)
1836 SetHiddenAttribute = True
1838 Exit_Function:
1839 Utils._ResetCalledSub(cstThisSub)
1840 Exit Function
1841 Error_NotFound:
1842 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
1843 Goto Exit_Function
1844 Error_Function:
1845 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1846 GoTo Exit_Function
1849 REM -----------------------------------------------------------------------------------------------------------------------
1850 Public Function SetOrderBy( _
1851 ByVal Optional pvOrder As Variant _
1852 , ByVal Optional pvControlName As Variant _
1853 ) As Boolean
1854 ' Sort ann open table, query, form or subform (if pvControlName present)
1856 If _ErrorHandler() Then On Local Error Goto Error_Function
1858 Utils._SetCalledSub(cstThisSub)
1859 SetOrderBy = False
1861 If IsMissing(pvOrder) Then pvOrder = ""
1862 If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function
1863 If IsMissing(pvControlName) Then pvControlName = ""
1864 If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function
1866 Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object
1867 Set oDatabase = Application._CurrentDb()
1868 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1870 sOrder = oDatabase._ReplaceSquareBrackets(pvOrder)
1872 Set oWindow = _SelectWindow()
1873 With oWindow
1874 Select Case .WindowType
1875 Case acForm
1876 Set oTarget = _DatabaseForm(._Name, pvControlName)
1877 Case acQuery, acTable
1878 If pvControlName <> "" Then Goto Exit_Function
1879 If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable
1881 Set oTarget = .Frame.Controller.FormOperations.Cursor
1882 Case Else ' Ignore action
1883 Goto Exit_Function
1884 End Select
1885 End With
1887 With oTarget
1888 .Order = sOrder
1889 .reload()
1890 End With
1891 SetOrderBy = True
1893 Exit_Function:
1894 Utils._ResetCalledSub(cstThisSub)
1895 Exit Function
1896 Error_NotApplicable:
1898 Goto Exit_Function
1899 Error_Function:
1900 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1901 GoTo Exit_Function
1904 REM -----------------------------------------------------------------------------------------------------------------------
1905 Public Function ShowAllrecords() As Boolean
1906 ' Removes any existing filter that exists on the current table, query or form
1908 If _ErrorHandler() Then On Local Error Goto Error_Function
1910 Utils._SetCalledSub(cstThisSub)
1911 ShowAllRecords = False
1913 Dim oWindow As Object, oDatabase As Object
1914 Set oDatabase = Application._CurrentDb()
1915 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
1917 Set oWindow = _SelectWindow()
1918 Select Case oWindow.WindowType
1919 Case acForm, acQuery, acTable
1920 RunCommand(acCmdRemoveFilterSort)
1921 ShowAllrecords = True
1922 Case Else ' Ignore action
1923 End Select
1925 Exit_Function:
1926 Utils._ResetCalledSub(cstThisSub)
1927 Exit Function
1928 Error_NotApplicable:
1930 Goto Exit_Function
1931 Error_Function:
1932 TraceError(TRACEABORT, Err, cstThisSub, Erl)
1933 GoTo Exit_Function
1936 REM -----------------------------------------------------------------------------------------------------------------------
1937 REM --- PRIVATE FUNCTIONS ---
1938 REM -----------------------------------------------------------------------------------------------------------------------
1939 Private Function _CheckColumnType(pvFindWhat As Variant, vDataField As Variant) As Boolean
1940 ' Return true if both arguments of the same type
1941 ' vDataField is a ResultSet column
1943 Dim bFound As Boolean
1944 bFound = False
1945 With com.sun.star.sdbc.DataType
1946 Select Case vDataField.Type
1947 Case .DATE, .TIME, .TIMESTAMP
1948 If VarType(pvFindWhat) = vbDate Then bFound = True
1949 Case .TINYINT, .SMALLINT, .INTEGER, .BIGINT, .FLOAT, .REAL, .DOUBLE, .NUMERIC, .DECIMAL
1950 If Utils._InList(VarType(pvFindWhat), Utils._AddNumeric()) Then bFound = True
1951 Case .CHAR, .VARCHAR, .LONGVARCHAR
1952 If VarType(pvFindWhat) = vbString Then bFound = True
1953 Case Else
1954 End Select
1955 End With
1957 _CheckColumnType = bFound
1961 REM -----------------------------------------------------------------------------------------------------------------------
1962 Private Function _DatabaseForm(psForm As String, psControl As String)
1963 'Return DatabaseForm element of Form object (based on psForm which is known as a real form name)
1964 'or of SubForm object (based on psControl which is checked for being a subform)
1966 Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer
1967 Dim bFound As Boolean, i As Integer, sName As String
1969 Set oForm = Application.Forms(psForm)
1971 With oForm.DatabaseForm
1972 iControlCount = .getCount()
1973 bFound = False
1975 sControls() = .getElementNames()
1976 sName = UCase(Utils._Trim(psControl))
1978 If UCase(sControls(i)) = sName Then
1979 bFound = True
1980 Exit For
1981 End If
1982 Next i
1983 End If
1984 End With
1985 If bFound Then sName = sControls(i) Else Goto Trace_NotFound
1986 Set oControl = oForm.Controls(sName)
1987 If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound
1988 Set _DatabaseForm = oControl.Form.DatabaseForm
1989 Else
1990 Set _DatabaseForm = oForm.DatabaseForm
1991 End If
1993 Exit_Function:
1994 Exit Function
1995 Trace_NotFound:
1996 TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm))
1997 Goto Exit_Function
1998 Trace_SubFormNotFound:
1999 TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm))
2000 Goto Exit_Function
2003 REM -----------------------------------------------------------------------------------------------------------------------
2004 Private Sub _DispatchCommand(ByVal psCommand As String)
2006 Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String
2007 Dim oResult As Variant
2008 Dim sCommand As String
2010 Set oDocument = _SelectWindow().Frame
2012 sTargetFrameName = ""
2013 oResult = oDispatcher.executeDispatch(oDocument, psCommand, sTargetFrameName, 0, oArgs())
2017 REM -----------------------------------------------------------------------------------------------------------------------
2018 Private Function _getTempDirectoryURL() As String
2019 ' Return the temporary directory defined in the OO Options (Paths)
2020 Dim sDirectory As String, oSettings As Object, oPathSettings As Object
2022 If _ErrorHandler() Then On Local Error Goto Error_Function
2024 _getTempDirectoryURL = ""
2028 _getTempDirectoryURL = sDirectory
2030 Exit_Function:
2031 Exit Function
2032 Error_Function:
2034 _getTempDirectoryURL = ""
2035 Goto Exit_Function
2038 REM -----------------------------------------------------------------------------------------------------------------------
2039 Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal psLastComponent As String) As String
2040 ' Return "Forms!myForm" from "Forms!myForm!datField" and "datField"
2042 If Len(psShortcut) > Len(psLastComponent) Then
2044 Else
2045 _getUpperShortcut = psShortcut
2046 End If
2048 End Function ' _getUpperShortcut
2050 REM -----------------------------------------------------------------------------------------------------------------------
2051 Private Function _OpenObject(ByVal psObjectType As String _
2052 , ByVal pvObjectName As Variant _
2053 , ByVal pvView As Variant _
2054 , ByVal pvDataMode As Variant _
2055 ) As Boolean
2057 If _ErrorHandler() Then On Local Error Goto Error_Function
2059 _OpenObject = False
2060 If Not (Utils._CheckArgument(pvObjectName, 1, vbString) _
2061 And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _
2062 And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _
2063 ) Then Goto Exit_Function
2064 Dim oDatabase As Object
2065 Set oDatabase = Application._CurrentDb()
2066 If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
2068 Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object
2069 Dim i As Integer, bFound As Boolean, lComponent As Long
2071 ' Check existence of object and find its exact (case-sensitive) name
2072 Select Case psObjectType
2074 sObjects = oDatabase.Connection.getTables.ElementNames()
2075 lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE
2077 sObjects = oDatabase.Connection.getQueries.ElementNames()
2078 lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY
2080 sObjects = oDatabase.Document.getReportDocuments.ElementNames()
2081 lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT
2082 End Select
2083 bFound = False
2084 For i = 0 To UBound(sObjects)
2085 If UCase(pvObjectName) = UCase(sObjects(i)) Then
2086 sObjectName = sObjects(i)
2087 bFound = True
2088 Exit For
2089 End If
2090 Next i
2091 If Not bFound Then Goto Trace_NotFound
2093 Set oController = oDatabase.Document.CurrentController
2094 Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign ))
2095 _OpenObject = True
2097 Exit_Function:
2098 Set oObject = Nothing
2099 Set oController = Nothing
2100 Exit Function
2101 Error_Function:
2103 GoTo Exit_Function
2104 Trace_Error:
2105 TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName))
2106 Goto Exit_Function
2107 Error_NotApplicable:
2109 Goto Exit_Function
2110 Trace_NotFound:
2111 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName))
2112 Goto Exit_Function
2115 REM -----------------------------------------------------------------------------------------------------------------------
2116 Private Function _PromptFormat() As String
2117 ' Return user selection in Format dialog
2119 Dim oDialog As Object, oDialogLib As Object, iOKCancel As Integer, oControl As Object
2120 Set oDialogLib = DialogLibraries
2122 If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev")
2123 Set oDialog = CreateUnoDialog(DialogLibraries.Access2BaseDev.dlgFormat)
2124 Else
2125 If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base")
2126 Set oDialog = CreateUnoDialog(DialogLibraries.Access2Base.dlgFormat)
2127 End If
2145 iOKCancel = oDialog.Execute()
2146 Select Case iOKCancel
2150 _PromptFormat = ""
2151 Case Else
2152 End Select
2153 oDialog.Dispose()
2157 REM -----------------------------------------------------------------------------------------------------------------------
2158 Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional ByVal psWindow As String) As Object
2159 ' No argument: find active window
2161 ' Return a _Window object type describing the found window
2163 Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer
2164 Dim bFound As Boolean, bActive As Boolean, sName As String, iType As Integer, sDocumentType As String
2165 Dim sImplementation As String, vLocation() As Variant
2166 Dim oWindow As _Window
2168 If _ErrorHandler() Then On Local Error Goto Error_Function
2170 bActive = IsMissing(piWindowType)
2171 If IsMissing(psWindow) Then psWindow = ""
2172 Set oWindow.Frame = Nothing
2173 oWindow.DocumentType = ""
2174 If bActive Then
2175 oWindow.WindowType = acDefault
2176 oWindow._Name = ""
2177 Else
2178 oWindow.WindowType = piWindowType
2179 Select Case piWindowType
2180 Case acBasicIDE, acDatabaseWindow : oWindow._Name = ""
2181 Case Else : oWindow._Name = psWindow
2182 End Select
2183 End If
2184 iType = acDefault
2185 sDocumentType = ""
2188 Set oEnum = oDesk.Components().createEnumeration
2189 Do While oEnum.hasMoreElements
2190 Set oComp = oEnum.nextElement
2191 If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = ""
2192 Select Case sImplementation
2194 Set oFrame = oComp.CurrentController.Frame
2195 iType = acBasicIDE
2196 sName = ""
2198 Set oFrame = oComp.CurrentController.Frame
2199 iType = acDatabaseWindow
2200 sName = ""
2203 Select Case oComp.Identifier
2205 iType = acForm
2207 iType = acReport
2210 If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = ""
2211 iType = acDocument
2212 sDocumentType = docWriter
2213 End Select
2214 If iType = acForm Or iType = acReport Then ' Identify Form or Report name
2215 For i = 0 To UBound(oComp.Args())
2217 sName = oComp.Args(i).Value
2218 Exit For
2219 End If
2220 Next i
2221 End If
2222 Set oFrame = oComp.CurrentController.Frame
2223 End If
2225 Set oFrame = oComp.Frame
2226 If Not IsEmpty(oComp.Selection) Then ' Empty for (F4) DatasourceBrowser !!
2227 For i = 0 To UBound(oComp.Selection())
2229 sName = oComp.Selection(i).Value
2231 Select Case oComp.selection(i).Value
2232 Case com.sun.star.sdb.CommandType.TABLE
2233 iType = acTable
2234 Case com.sun.star.sdb.CommandType.QUERY
2235 iType = acQuery
2236 Case com.sun.star.sdb.CommandType.COMMAND
2237 iType = acQuery ' SQL for future use ?
2238 End Select
2239 End If
2240 Next i
2241 ' Else ignore
2242 End If
2243 Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode
2244 If Not bActive Then
2245 If UCase(Right(oComp.Title, Len(psWindow))) = UCase(psWindow) Then ' No rigorous mean found to identify Name
2246 Set oFrame = oComp.Frame
2247 Select Case sImplementation
2250 End Select
2251 sName = Right(oComp.Title, Len(psWindow))
2252 End If
2253 Else
2254 Set oFrame = Nothing
2255 End If
2257 Set oFrame = oComp.Frame
2258 iType = acDiagram
2259 sName = ""
2261 Set oFrame = oComp.Frame
2262 iType = acWelcome
2263 sName = ""
2264 Case Else ' Other Calc, ..., whatever documents
2267 If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = ""
2268 iType = acDocument
2270 Select Case oComp.Identifier
2275 Case Else : sDocumentType = ""
2276 End Select
2277 End If
2278 Set oFrame = oComp.CurrentController.Frame
2279 End If
2280 End Select
2281 If bActive And Not IsNull(oFrame) Then
2282 If oFrame.ContainerWindow.IsActive() Then
2283 bFound = True
2284 Exit Do
2285 End If
2286 ElseIf iType = piWindowType And UCase(sName) = UCase(psWindow) Then
2287 bFound = True
2288 Exit Do
2289 End If
2290 Loop
2292 If bFound Then
2293 Set oWindow.Frame = oFrame
2294 oWindow._Name = sName
2295 oWindow.WindowType = iType
2296 oWindow.DocumentType = sDocumentType
2297 Else
2298 Set oWindow.Frame = Nothing
2299 End If
2301 Exit_Function:
2302 Set _SelectWindow = oWindow
2303 Exit Function
2304 Error_Function:
2306 GoTo Exit_Function
2309 REM -----------------------------------------------------------------------------------------------------------------------
2310 Private Function _SendWithAttachment( _
2311 ByVal pvRecipients() As Variant _
2312 , ByVal pvCcRecipients() As Variant _
2313 , ByVal pvBccRecipients() As Variant _
2314 , ByVal psSubject As String _
2315 , ByVal pvAttachments() As Variant _
2316 , ByVal pvBody As String _
2317 , ByVal pbEditMessage As Boolean _
2318 ) As Boolean
2320 ' Send message with attachments
2321 If _ErrorHandler() Then On Local Error Goto Error_Function
2322 _SendWithAttachment = False
2324 Const cstWindows = 1
2325 Const cstLinux = 4
2327 Dim oServiceMail as Object, oMail As Object, oMessage As Object, vFlag As Variant
2328 Dim vCc() As Variant, i As Integer, iOS As Integer, sProduct As String, bMailProvider As Boolean
2330 'OPENOFFICE <= 3.6 and LIBREOFFICE have XSimple...Mail interface while OPENOFFICE >= 4.0 has XSystemMailProvider interface
2331 sProduct = UCase(Utils._GetProductName())
2332 bMailProvider = ( Left(sProduct, 4) = "OPEN" And Left(_GetProductName("VERSION"), 3) >= "4.0" )
2334 iOS = GetGuiType()
2335 Select Case iOS
2336 Case cstLinux
2338 Case cstWindows
2339 If bMailProvider Then oServiceMail = createUnoService("com.sun.star.system.SystemMailProvider") _
2341 Case Else
2342 Goto Error_Mail
2343 End Select
2345 If bMailProvider Then Set oMail = oServiceMail.queryMailClient() _
2346 Else Set oMail = oServiceMail.querySimpleMailClient()
2347 If IsNull(oMail) Then Goto Error_Mail
2352 Else
2355 vCc(i) = pvRecipients(i + 1)
2356 Next i
2357 For i = UBound(pvRecipients) To UBound(vCc)
2358 vCc(i) = pvCcRecipients(i - UBound(pvRecipients))
2359 Next i
2360 End If
2362 If bMailProvider Then
2363 Set oMessage = oMail.createMailMessage()
2365 If psSubject <> "" Then oMessage.Subject = psSubject
2366 Select Case iOS ' Not published differences between com.sun.star.system.SimpleCommandMail and SimpleSystemMail
2367 Case cstLinux
2369 If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = Array(Join(pvBccRecipients, cstSemiColon))
2370 Case cstWindows
2373 End Select
2375 If pvBody <> "" Then oMessage.Body = pvBody
2376 If pbEditMessage Then
2377 vFlag = com.sun.star.system.MailClientFlags.DEFAULTS
2378 Else
2379 vFlag = com.sun.star.system.MailClientFlags.NO_USER_INTERFACE
2380 End If
2381 oMail.sendMailMessage(oMessage, vFlag)
2382 Else
2383 Set oMessage = oMail.createSimpleMailMessage() ' Body NOT SUPPORTED !
2385 If psSubject <> "" Then oMessage.setSubject(psSubject)
2386 Select Case iOS
2387 Case cstLinux
2389 If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(Array(Join(pvBccRecipients, cstSemiColon)))
2390 Case cstWindows
2393 End Select
2395 If pbEditMessage Then
2396 vFlag = com.sun.star.system.SimpleMailClientFlags.DEFAULTS
2397 Else
2398 vFlag = com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE
2399 End If
2400 oMail.sendSimpleMailMessage(oMessage, vFlag)
2401 End If
2403 _SendWithAttachment = True
2405 Exit_Function:
2406 Exit Function
2407 Error_Function:
2409 Goto Exit_Function
2410 Error_Mail:
2411 TraceError(TRACEFATAL, ERRSENDMAIL, Utils._CalledSub(), 0)
2412 Goto Exit_Function
2415 REM -----------------------------------------------------------------------------------------------------------------------
2416 Private Function _SendWithoutAttachment(ByVal pvTo As Variant _
2417 , ByVal pvCc As Variant _
2418 , ByVal pvBcc As Variant _
2419 , ByVal psSubject As String _
2420 , ByVal psBody As String _
2421 ) As Boolean
2422 'Send simple message with mailto: syntax
2423 Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, sSubject As String, sBody As String, oDispatch As Object
2428 If _ErrorHandler() Then On Local Error Goto Error_Function
2433 If psSubject <> "" Then sSubject = Join(Split(psSubject, " "), cstSpace) Else sSubject = ""
2434 If psBody <> "" Then
2435 sBody = Join(Split(psBody, Chr(13)), cstCR)
2436 sBody = Join(Split(sBody, " "), cstSpace)
2437 End If
2441 & Iif(sCc = "", "", "cc=" & sCc & "&") _
2442 & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _
2443 & Iif(sSubject = "", "", "subject=" & sSubject & "&") _
2444 & Iif(sBody = "", "", "body=" & sBody & "&")
2445 If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1)
2450 _SendWithoutAttachment = True
2452 Exit_Function:
2453 Exit Function
2454 Error_Function:
2456 _SendWithoutAttachment = False
2457 Goto Exit_Function
2460 REM -----------------------------------------------------------------------------------------------------------------------
2461 Private Sub _ShellExecute(sCommand As String)
2462 ' Execute shell command
2464 Dim oShell As Object
2466 oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.DEFAULTS)
2469 </script:module>