REM ======================================================================================================================= REM === The Access2Base library is a part of the LibreOffice project. === REM === Full documentation is available on http://www.access2base.com === REM ======================================================================================================================= Option Explicit Type _FindParams FindRecord As Integer ' Set to 1 at first invocation of FindRecord FindWhat As Variant Match As Integer MatchCase As Boolean Search As Integer SearchAsFormatted As Boolean ' Must be False FindFirst As Boolean OnlyCurrentField As Integer Form As String ' Shortcut GridControl As String ' Shortcut Target As String ' Shortcut LastRow As Long ' Last row explored - 0 = before first LastColumn As Integer ' Last column explored - 0 ... N-1 index in next arrays; 0 if OnlyCurrentField = acCurrent ColumnNames() As String ' Array of column names in grid with boundfield and of same type as FindWhat ResultSetIndex() As Integer ' Array of column numbers in ResultSet End Type Type _Window Frame As Object ' com.sun.star.comp.framework.Frame _Name As String ' Object Name WindowType As Integer ' One of the object types DocumentType As String ' Writer, Calc, ... - Only if WindowType = acDocument End Type REM VBA allows call to actions with missing arguments e.g. OpenForm("aaa",,"[field]=2") REM in StarBasic IsMissing requires Variant parameters REM ----------------------------------------------------------------------------------------------------------------------- Public Function ApplyFilter( _ ByVal Optional pvFilter As Variant _ , ByVal Optional pvSQL As Variant _ , ByVal Optional pvControlName As Variant _ ) As Boolean ' Set filter on open table, query, form or subform (if pvControlName present) If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "ApplyFilter" Utils._SetCalledSub(cstThisSub) ApplyFilter = False If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments() If IsMissing(pvFilter) Then pvFilter = "" If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function If IsMissing(pvSQL) Then pvSQL = "" If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function If IsMissing(pvControlName) Then pvControlName = "" If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable If pvSQL <> "" _ Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _ Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter) Set oWindow = _SelectWindow() With oWindow Select Case .WindowType Case acForm Set oTarget = _DatabaseForm(._Name, pvControlName) Case acQuery, acTable If pvControlName <> "" Then Goto Exit_Function If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable ' FormOperations returns <Null> in OpenOffice Set oTarget = .Frame.Controller.FormOperations.Cursor Case Else ' Ignore action Goto Exit_Function End Select End With With oTarget .Filter = sFilter .ApplyFilter = True .reload() End With ApplyFilter = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' ApplyFilter V1.2.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function mClose(Optional ByVal pvObjectType As Variant _ , Optional ByVal pvObjectName As Variant _ , Optional ByVal pvSave As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "Close" Utils._SetCalledSub(cstThisSub) mClose = False If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments() If IsMissing(pvSave) Then pvSave = acSavePrompt If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ Array(acTable, acQuery, acForm, acReport)) _ And Utils._CheckArgument(pvObjectName, 2, vbString) _ And Utils._CheckArgument(pvSave, 3, Utils._AddNumeric(), Array(acSavePrompt)) _ ) Then Goto Exit_Function Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object Dim i As Integer, bFound As Boolean, lComponent As Long Dim oDatabase As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable ' Check existence of object and find its exact (case-sensitive) name Select Case pvObjectType Case acForm sObjects = Application._GetAllHierarchicalNames() lComponent = com.sun.star.sdb.application.DatabaseObject.FORM Case acTable sObjects = oDatabase.Connection.getTables.ElementNames() lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE Case acQuery sObjects = oDatabase.Connection.getQueries.ElementNames() lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY Case acReport sObjects = oDatabase.Document.getReportDocuments.ElementNames() lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT End Select bFound = False For i = 0 To UBound(sObjects) If UCase(pvObjectName) = UCase(sObjects(i)) Then sObjectName = sObjects(i) bFound = True Exit For End If Next i If Not bFound Then Goto Trace_NotFound Select Case pvObjectType Case acForm Set oController = oDatabase.Document.getFormDocuments.getByHierarchicalName(sObjectName) mClose = oController.close() Case acTable, acQuery ' Not optimal but it works !! Set oController = oDatabase.Document.CurrentController Set oObject = oController.loadComponent(lComponent, sObjectName, False) oObject.frame.close(False) mClose = True Case acReport Set oController = oDatabase.Document.getReportDocuments.getByName(sObjectName) mClose = oController.close() End Select Exit_Function: Set oObject = Nothing Set oController = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, "Close", Erl) GoTo Exit_Function Trace_Error: TraceError(TRACEFATAL, ERRCLOSEOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) Goto Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) Goto Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function End Function ' (m)Close V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function CopyObject(ByVal Optional pvSourceDatabase As Variant _ , ByVal Optional pvNewName As Variant _ , ByVal Optional pvSourceType As Variant _ , ByVal Optional pvSourceName As Variant _ ) As Boolean ' Copies tables and queries into identical (new) objects If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "CopyObject" Utils._SetCalledSub(cstThisSub) CopyObject = False If IsMissing(pvSourceDatabase) Then pvSourceDatabase = "" If VarType(pvSourceDatabase) <> vbString Then If Not Utils._CheckArgument(pvSourceDatabase, 1, OBJDATABASE) Then Goto Exit_Function End If If IsMissing(pvNewName) Then Call _TraceArguments() If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function If IsMissing(pvSourceType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _ ) Then Goto Exit_Function If IsMissing(pvSourceName) Then Call _TraceArguments() If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto Exit_Function Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase As Object, bSameDatabase As Boolean Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object, oTargetCol As Object, iRDBMS As Integer Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant Dim vNameComponents() As Variant, iNames As Integer, sSurround As String Dim vInputField As Variant, vFieldBinary() As Variant, vOutputField As Variant Dim oInput as Object, oOutput As Object, iNbFields As Integer, vValue As Variant Dim vBinary As Variant, lInputSize As Long, lOutputSize As Long Dim lInputRecs As Long, lInputMax As Long, vField As Variant, bProgressMeter As Boolean, sFile As String Const cstMaxBinlength = 2 * 65535 Const cstChunkSize = 2 * 65535 Const cstProgressMeterLimit = 100 Set oDatabase = Application._CurrentDb() bSameDatabase = False If VarType(pvSourceDatabase) = vbString Then If pvSourceDatabase = "" Then Set oSourceDatabase = oDatabase bSameDatabase = True Else Set oSourceDatabase = Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), , , True) If IsNull(oSourceDatabase) Then Goto Exit_Function End If Else Set oSourceDatabase = pvSourceDatabase End If With oDatabase iRDBMS = ._RDBMS If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Select Case pvSourceType Case acQuery Set oSource = oSourceDatabase.QueryDefs(pvSourceName, True) If IsNull(oSource) Then Goto Error_NotFound Set oTarget = .QueryDefs(pvNewName, True) If Not IsNull(oTarget) Then .Connection.getQueries.dropByName(oTarget.Name) ' a query with same name exists already ... drop it If oSource.Query.EscapeProcessing Then Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL) Else Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough) End If ' Save .odb document .Document.store() Case acTable Set oSource = oSourceDatabase.TableDefs(pvSourceName, True) If IsNull(oSource) Then Goto Error_NotFound Set oTarget = .TableDefs(pvNewName, True) ' A table with same name exists already ... drop it If Not IsNull(oTarget) Then .Connection.getTables.dropByName(oTarget.Name) ' Copy source table columns Set oSourceTable = oSource.Table Set oTarget = .Connection.getTables.createDataDescriptor oTarget.Description = oSourceTable.Description vNameComponents = Split(pvNewName, ".") iNames = UBound(vNameComponents) If iNames >= 2 Then oTarget.CatalogName = vNameComponents(iNames - 2) Else oTarget.CatalogName = "" If iNames >= 1 Then oTarget.SchemaName = vNameComponents(iNames - 1) Else oTarget.SchemaName = "" oTarget.Name = vNameComponents(iNames) oTarget.Type = oSourceTable.Type Set oSourceColumns = oSourceTable.Columns Set oTargetCol = oTarget.Columns.createDataDescriptor For i = 0 To oSourceColumns.getCount() - 1 ' Append each individual column to the table descriptor Set oSourceCol = oSourceColumns.getByIndex(i) _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase oTarget.Columns.appendByDescriptor(oTargetCol) Next i ' Copy keys Set oSourceKeys = oSourceTable.Keys Set oTargetKey = oTarget.Keys.createDataDescriptor() For i = 0 To oSourceKeys.getCount() - 1 ' Append each key to table descriptor Set oSourceKey = oSourceKeys.getByIndex(i) oTargetKey.DeleteRule = oSourceKey.DeleteRule oTargetKey.Name = oSourceKey.Name oTargetKey.ReferencedTable = oSourceKey.ReferencedTable oTargetKey.Type = oSourceKey.Type oTargetKey.UpdateRule = oSourceKey.UpdateRule Set oTargetCol = oTargetKey.Columns.createDataDescriptor() For j = 0 To oSourceKey.Columns.getCount() - 1 Set oSourceCol = oSourceKey.Columns.getByIndex(j) _ConvertDataDescriptor oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase, True oTargetKey.Columns.appendByDescriptor(oTargetCol) Next j oTarget.Keys.appendByDescriptor(oTargetKey) Next i ' Duplicate table whole design .Connection.getTables.appendByDescriptor(oTarget) ' Copy data Select Case bSameDatabase Case True ' Build SQL statement to copy data sSurround = Utils._Surround(oSource.Name) sSql = "INSERT INTO " & Utils._Surround(pvNewName) & " SELECT " & sSurround & ".* FROM " & sSurround DoCmd.RunSQL(sSql) Case False ' Copy data row by row and field by field ' As it is slow ... display a progress meter Set oInput = oSourceDatabase.OpenRecordset(oSource.Name, , , dbReadOnly) Set oOutput = .Openrecordset(pvNewName) With oInput If Not ( ._BOF And ._EOF ) Then .MoveLast lInputMax = .RecordCount lInputRecs = 0 .MoveFirst bProgressMeter = ( lInputMax > cstProgressMeterLimit ) iNbFields = .Fields().Count - 1 vFieldBinary = Array() ReDim vFieldBinary(0 To iNbFields) For i = 0 To iNbFields vFieldBinary(i) = Utils._IsBinaryType(.Fields(i).Column.Type) Next i Else bProgressMeter = False End If If bProgressMeter Then Application.SysCmd acSysCmdInitMeter, pvNewName & " 0 %", lInputMax Do While Not .EOF() oOutput.RowSet.moveToInsertRow() oOutput._EditMode = dbEditAdd For i = 0 To iNbFields Set vInputField = .Fields(i) Set vOutputField = oOutput.Fields(i) If vFieldBinary(i) Then lInputSize = vInputField.FieldSize If lInputSize <= cstMaxBinlength Then vField = Utils._getResultSetColumnValue(.RowSet, i + 1, True) Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField) ElseIf oDatabase._BinaryStream Then ' Typically for SQLite where binary fields are limited If lInputSize > vOutputField._Precision Then TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1)) Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, Null) Else sFile = Utils._GetRandomFileName("BINARY") vInputField._WriteAll(sFile, "WriteAllBytes") vOutputField._ReadAll(sFile, "ReadAllBytes") Kill ConvertToUrl(sFile) End If End If Else vField = Utils._getResultSetColumnValue(.RowSet, i + 1) If VarType(vField) = vbString Then If Len(vField) > vOutputField._Precision Then TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0, 1, Array(vOutputField._Name, lInputRecs + 1)) End If End If ' Update is done anyway, if too long, with truncation Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField) End If Next i If oOutput.RowSet.IsNew And oOutput.RowSet.IsModified Then oOutput.RowSet.insertRow() oOutput._EditMode = dbEditNone lInputRecs = lInputRecs + 1 If bProgressMeter Then If lInputRecs Mod (lInputMax / 100) = 0 Then Application.SysCmd acSysCmdUpdateMeter, pvNewName & " " & CStr(CLng(lInputRecs * 100 / lInputMax)) & "%", lInputRecs End If End If .MoveNext Loop End With oOutput.mClose() Set oOutput = Nothing oInput.mClose() Set oInput = Nothing if bProgressMeter Then Application.SysCmd acSysCmdClearStatus End Select Case Else End Select End With CopyObject = True Exit_Function: ' Avoid closing the current database or the database object given as source argument If VarType(pvSourceDatabase) = vbString And Not bSameDatabase Then If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose() End If Set oSourceDatabase = Nothing If Not IsNull(oOutput) Then oOutput.mClose() Set oOutput = Nothing If Not IsNull(oInput) Then oInput.mClose() Set oInput = Nothing Set oSourceCol = Nothing Set oSourceKey = Nothing Set oSourceKeys = Nothing Set oSource = Nothing Set oSourceTable = Nothing Set oSourceColumns = Nothing Set oTargetCol = Nothing Set oTargetKey = Nothing Set oTarget = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName)) Goto Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' CopyObject V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function FindNext() As Boolean ' Must be called after a FindRecord ' Execute instructions set in FindRecord object If _ErrorHandler() Then On Local Error Goto Error_Function FindNext = False Utils._SetCalledSub("FindNext") Dim ofForm As Object, ocGrid As Object Dim i As Integer, lInitialRow As Long, lFindRow As Long Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean Dim vFindValue As Variant, oFindrecord As Object Set oFindRecord = _A2B_.FindRecord If IsNull(oFindRecord) Then GoTo Error_FindRecord With oFindRecord If .FindRecord = 0 Then Goto Error_FindRecord .FindRecord = 0 Set ofForm = getObject(.Form) If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola Set ocGrid = getObject(.GridControl) ' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween If ofForm.DatabaseForm.RowCount <= 0 then Goto Exit_Function ' Dataset is empty lInitialRow = .LastRow ' Used if Search = acSearchAll bFound = False lFindRow = .LastRow b2ndRound = False Do ' Last column ? Go to next row If .LastColumn >= UBound(.ColumnNames) Then bStop = False If ofForm.DatabaseForm.isAfterLast() And .Search = acUp Then ofForm.DatabaseForm.last() ElseIf ofForm.DatabaseForm.isLast() And .Search = acSearchAll Then ofForm.DatabaseForm.first() b2ndRound = True ElseIf ofForm.DatabaseForm.isBeforeFirst() And (.Search = acDown Or .Search = acSearchAll) Then ofForm.DatabaseForm.first() ElseIf ofForm.DatabaseForm.isFirst() And .search = acUp Then ofForm.DatabaseForm.beforeFirst() bStop = True ElseIf ofForm.DatabaseForm.isLast() And .search = acDown Then ofForm.DatabaseForm.afterLast() bStop = True ElseIf .Search = acUp Then ofForm.DatabaseForm.previous() Else ofForm.DatabaseForm.next() End If lFindRow = ofForm.DatabaseForm.getRow() If bStop Or (.Search = acSearchAll And lFindRow >= lInitialRow And b2ndRound) Then ofForm.DatabaseForm.absolute(lInitialRow) Exit Do End If .LastColumn = 0 Else .LastColumn = .LastColumn + 1 End If ' Examine column contents If .LastColumn <= UBound(.ColumnNames) Then For i = .LastColumn To UBound(.ColumnNames) vFindValue = Utils._getResultSetColumnValue(ofForm.DatabaseForm.createResultSet(), .ResultSetIndex(i)) Select Case VarType(.FindWhat) Case vbDate, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal bFound = ( .FindWhat = vFindValue ) Case vbString If VarType(vFindValue) = vbString Then Select Case .Match Case acStart If .MatchCase Then bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue ) Else bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) ) End If Case acAnyWhere If .MatchCase Then bFound = ( InStr(1, vFindValue, .FindWhat, 0) > 0 ) Else bFound = ( InStr(vFindValue, .FindWhat) > 0 ) End If Case acEntire If .MatchCase Then bFound = ( .FindWhat = vFindValue ) Else bFound = ( UCase(.FindWhat) = UCase(vFindValue) ) End If End Select Else bFound = False End If End Select If bFound Then .LastColumn = i Exit For End If Next i End If Loop While Not bFound .LastRow = lFindRow If bFound Then ocGrid.Controls(.ColumnNames(.LastColumn)).setFocus() .FindRecord = 1 FindNext = True End If End With Exit_Function: Utils._ResetCalledSub("FindNext") Exit Function Error_Function: TraceError(TRACEABORT, Err, "FindNext", Erl) GoTo Exit_Function Error_FindRecord: TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0) Goto Exit_Function End Function ' FindNext V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function FindRecord(Optional ByVal pvFindWhat As Variant _ , Optional ByVal pvMatch As Variant _ , Optional ByVal pvMatchCase As Variant _ , Optional ByVal pvSearch As Variant _ , Optional ByVal pvSearchAsFormatted As Variant _ , Optional ByVal pvTargetedField As Variant _ , Optional ByVal pvFindFirst As Variant _ ) As Boolean 'Find a value (string or other) in the underlying data of a gridcontrol 'Search in all columns or only in one single control ' see pvTargetedField = acAll or acCurrent ' pvTargetedField may also be a shortcut to a GridControl or one of its subcontrols 'Initialize _Findrecord structure in Database root and call FindNext() to set cursor on found value If _ErrorHandler() Then On Local Error Goto Error_Function FindRecord = False Utils._SetCalledSub("FindRecord") If IsMissing(pvFindWhat) Or pvFindWhat = "" Then Call _TraceArguments() If IsMissing(pvMatch) Then pvMatch = acEntire If IsMissing(pvMatchCase) Then pvMatchCase = False If IsMissing(pvSearch) Then pvSearch = acSearchAll If IsMissing(pvSearchAsFormatted) Then pvSearchAsFormatted = False ' Anyway only False supported If IsMissing(pvTargetedField) Then pvTargetedField = acCurrent If IsMissing(pvFindFirst) Then pvFindFirst = True If Not (Utils._CheckArgument(pvFindWhat, 1, Utils._AddNumeric(Array(vbString, vbDate))) _ And Utils._CheckArgument(pvMatch, 2, Utils._AddNumeric(), Array(acAnywhere, acEntire, acStart)) _ And Utils._CheckArgument(pvMatchCase, 3, vbBoolean) _ And Utils._CheckArgument(pvSearch, 4, Utils._AddNumeric(), Array(acDown, acSearchAll, acUp)) _ And Utils._CheckArgument(pvSearchAsFormatted, 5, vbBoolean, Array(False)) _ And Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(vbString)) _ And Utils._CheckArgument(pvFindFirst, 7, vbBoolean) _ ) Then Exit Function If VarType(pvTargetedField) <> vbString Then If Not Utils._CheckArgument(pvTargetedField, 6, Utils._AddNumeric(), Array(acAll, acCurrent)) Then Exit Function End If Dim ocTarget As Object, i As Integer, j As Integer, vNames() As Variant, iCount As Integer, vIndexes() As Variant Dim vColumn As Variant, vDataField As Variant, ofParentForm As Variant, oColumns As Object, vParentGrid As Object Dim bFound As Boolean, ocGridControl As Object, iFocus As Integer Dim oFindRecord As _FindParams With oFindRecord .FindRecord = 0 .FindWhat = pvFindWhat .Match = pvMatch .MatchCase = pvMatchCase .Search = pvSearch .SearchAsFormatted = pvSearchAsFormatted .FindFirst = pvFindFirst ' Determine target ' Either: pvTargetedField = Grid => search all fields ' pvTargetedField = Control in Grid => search only in that column ' pvTargetedField = acAll or acCurrent => determine focus Select Case True Case VarType(pvTargetedField) = vbString Set ocTarget = getObject(pvTargetedField) If ocTarget.SubType = CTLGRIDCONTROL Then .OnlyCurrentField = acAll .GridControl = ocTarget._Shortcut .Target = .GridControl ofParentForm = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name)) If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns iCount = -1 For i = 0 To ocTarget.ControlModel.Count - 1 Set vColumn = ocTarget.ControlModel.getByIndex(i) Set vDataField = vColumn.BoundField ' examine field type If Not IsNull(vDataField) Then If _CheckColumnType(pvFindWhat, vDataField) Then iCount = iCount + 1 ReDim Preserve vNames(0 To iCount) vNames(iCount) = vColumn.Name ReDim Preserve vIndexes(0 To iCount) For j = 0 To oColumns.Count - 1 If vDataField.Name = oColumns.ElementNames(j) Then vIndexes(iCount) = j + 1 Exit For End If Next j End If End If Next i ElseIf ocTarget._Type = OBJCONTROL Then ' Control within a grid tbc If IsNull(ocTarget.ControlModel.BoundField) Then Goto Error_Target ' Control MUST be bound to a database record or query ' BoundField is in ControlModel, thanks PASTIM ! .OnlyCurrentField = acCurrent vParentGrid = getObject(_getUpperShortcut(ocTarget._Shortcut, ocTarget._Name)) If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target .GridControl = vParentGrid._Shortcut ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name)) If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm .Target = ocTarget._Shortcut Set vDataField = ocTarget.ControlModel.BoundField If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target ReDim vNames(0), vIndexes(0) vNames(0) = ocTarget._Name Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns For j = 0 To oColumns.Count - 1 If vDataField.Name = oColumns.ElementNames(j) Then vIndexes(0) = j + 1 Exit For End If Next j End If Case Else ' Determine focus iCount = Application.Forms()._Count If iCount = 0 Then Goto Error_ActiveForm bFound = False For i = 0 To iCount - 1 ' Determine form having the focus Set ofParentForm = Application.Forms(i) If ofParentForm.Component.CurrentController.Frame.IsActive() Then bFound = True Exit For End If Next i If Not bFound Then Goto Error_ActiveForm If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm iCount = ofParentForm.Controls().Count bFound = False For i = 0 To iCount - 1 Set ocGridControl = ofParentForm.Controls(i) If ocGridControl.SubType = CTLGRIDCONTROL Then bFound = True Exit For End If Next i If Not bFound Then Goto Error_NoGrid .GridControl= ocGridControl._Shortcut iFocus = -1 iFocus = ocGridControl.ControlView.getCurrentColumnPosition() ' Deprecated but no alternative found !! If pvTargetedField = acAll Or iFocus < 0 Or iFocus >= ocGridControl.ControlModel.Count Then ' Has a control within the grid the focus ? NO .OnlyCurrentField = acAll Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns iCount = -1 For i = 0 To ocGridControl.ControlModel.Count - 1 Set vColumn = ocGridControl.ControlModel.getByIndex(i) Set vDataField = vColumn.BoundField ' examine field type If Not IsNull(vDataField) Then If _CheckColumnType(pvFindWhat, vDataField) Then iCount = iCount + 1 ReDim Preserve vNames(0 To iCount) vNames(iCount) = vColumn.Name ReDim Preserve vIndexes(0 To iCount) For j = 0 To oColumns.Count - 1 If vDataField.Name = oColumns.ElementNames(j) Then vIndexes(iCount) = j + 1 Exit For End If Next j End If End If Next i Else ' Has a control within the grid the focus ? YES .OnlyCurrentField = acCurrent Set vColumn = ocGridControl.ControlModel.getByIndex(iFocus) Set ocTarget = ocGridControl.Controls(vColumn.Name) .Target = ocTarget._Shortcut Set vDataField = ocTarget.ControlModel.BoundField If IsNull(vDataField) Then Goto Error_Target ' Control MUST be bound to a database record or query If Not _CheckColumnType(pvFindWhat, vDataField) Then Goto Error_Target ReDim vNames(0), vIndexes(0) vNames(0) = ocTarget._Name Set oColumns = ofParentForm.DatabaseForm.createResultSet().Columns For j = 0 To oColumns.Count - 1 If vDataField.Name = oColumns.ElementNames(j) Then vIndexes(0) = j + 1 Exit For End If Next j End If End Select .Form = ofParentForm._Shortcut .LastColumn = UBound(vNames) .ColumnNames = vNames .ResultSetIndex = vIndexes If pvFindFirst Then Select Case pvSearch Case acDown, acSearchAll ofParentForm.DatabaseForm.beforeFirst() .LastRow = 0 Case acUp ofParentForm.DatabaseForm.afterLast() .LastRow = ofParentForm.DatabaseForm.RowCount + 1 End Select Else Select Case True Case ofParentForm.DatabaseForm.isBeforeFirst And (pvSearch = acSearchAll Or pvSearch = acDown) .LastRow = 0 Case ofParentForm.DatabaseForm.isAfterLast And pvSearch = acUp ofParentForm.DatabaseForm.last() ' RowCount produces a wrong value as long as last record has not been reached .LastRow = ofParentForm.DatabaseForm.RowCount + 1 Case Else .LastRow = ofParentForm.DatabaseForm.getRow() End Select End If .FindRecord = 1 End With Set _A2B_.FindRecord = oFindRecord FindRecord = DoCmd.Findnext() Exit_Function: Utils._ResetCalledSub("FindRecord") Exit Function Error_Function: TraceError(TRACEABORT, Err, "FindRecord", Erl) GoTo Exit_Function Error_ActiveForm: TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0) Goto Exit_Function Error_DatabaseForm: TraceError(TRACEFATAL, ERRDATABASEFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) Goto Exit_Function Error_Target: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(6, pvTargetedField)) Goto Exit_Function Error_NoGrid: TraceError(TRACEFATAL, ERRNOGRIDINFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) Goto Exit_Function End Function ' FindRecord V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _ , ByVal Optional pvObjectName As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "GetHiddenAttribute" Utils._SetCalledSub(cstThisSub) If IsMissing(pvObjectType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ ) Then Goto Exit_Function If IsMissing(pvObjectName) Then Select Case pvObjectType Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() Case Else End Select pvObjectName = "" Else If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function End If Dim oWindow As Object Set oWindow = _SelectWindow(pvObjectType, pvObjectName) If IsNull(oWindow.Frame) Then Goto Error_NotFound GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible() Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' GetHiddenAttribute V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function GoToControl(Optional ByVal pvControlName As variant) As Boolean ' Set the focus on the named control on the active form. ' Return False if the control does not exist or is disabled, If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("GoToControl") If IsMissing(pvControlName) Then Call _TraceArguments() If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function GoToControl = False Dim oWindow As Object, ofForm As Object, ocControl As Object Dim i As Integer, iCount As Integer Set oWindow = _SelectWindow() If oWindow.WindowType = acForm Then Set ofForm = Application.Forms(oWindow._Name) iCount = ofForm.Controls().Count For i = 0 To iCount - 1 ocControl = ofForm.Controls(i) If UCase(ocControl._Name) = UCase(pvControlName) Then If Methods.hasProperty(ocControl, "Enabled") Then If ocControl.Enabled Then ocControl.setFocus() GoToControl = True Exit For End If End If End If Next i End If Exit_Function: Utils._ResetCalledSub("GoToControl") Exit Function Error_Function: TraceError(TRACEABORT, Err, "GoToControl", Erl) GoTo Exit_Function End Function ' GoToControl V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function GoToRecord(Optional ByVal pvObjectType As Variant _ , Optional ByVal pvObjectName As Variant _ , Optional ByVal pvRecord As Variant _ , Optional ByVal pvOffset As Variant _ ) As Boolean 'Move to record indicated by pvRecord/pvOffset in the window designated by pvObjectType and pvObjectName If _ErrorHandler() Then On Local Error Goto Error_Function GoToRecord = False Const cstThisSub = "GoTorecord" Utils._SetCalledSub(cstThisSub) If IsMissing(pvObjectName) Then pvObjectName = "" If IsMissing(pvObjectType) Then pvObjectType = acActiveDataObject If IsMissing(pvRecord) Then pvRecord = acNext If IsMissing(pvOffset) Then pvOffset = 1 If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _ , Array(acActiveDataObject, acDataForm, acDataQuery, acDataTable)) _ And Utils._CheckArgument(pvObjectName, 2, vbString) _ And Utils._CheckArgument(pvRecord, 3, Utils._AddNumeric() _ , Array(acFirst, acGoTo, acLast, acNewRec, acNext, acPrevious)) _ And Utils._CheckArgument(pvOffset, 4, Utils._AddNumeric()) _ ) Then Goto Exit_Function If pvObjectType = acActiveDataObject And pvObjectName <> "" Then Goto Error_Target If pvOffset < 0 And pvRecord <> acGoTo Then Goto Error_Offset Dim ofForm As Object, oGeneric As Object, oResultSet As Object, oWindow As Object Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long Dim sObjectName, iLengthName As Integer Select Case pvObjectType Case acActiveDataObject Set oWindow = _SelectWindow() With oWindow Select Case .WindowType Case acForm Set oResultSet = _DatabaseForm(._Name, "") Case acQuery, acTable If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable ' FormOperations returns <Null> in OpenOffice Set oResultSet = .Frame.Controller.FormOperations.Cursor Case Else ' Ignore action Goto Exit_Function End Select End With Case acDataForm ' pvObjectName can be "myForm", "Forms!myForm", "Forms!myForm!mySubform" or "Forms!myForm!mySubform.Form" sObjectName = UCase(pvObjectName) iLengthName = Len(sObjectName) Select Case True Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" And Right(sObjectName, 5) = ".FORM" Set ofForm = getObject(pvObjectName) If ofForm._Type <> OBJSUBFORM Then Goto Error_Target Case iLengthName > 6 And Left(sObjectName, 6) = "FORMS!" Set oGeneric = getObject(pvObjectName) If oGeneric._Type = OBJFORM Or oGeneric._Type = OBJSUBFORM Then Set ofForm = oGeneric ElseIf oGeneric.SubType = CTLSUBFORM Then Set ofForm = oGeneric.Form Else Goto Error_Target End If Case sObjectName = "" Call _TraceArguments() Case Else Set ofForm = Application.Forms(pvObjectName) End Select Set oResultSet = ofForm.DatabaseForm Case acDataQuery Set oWindow = _SelectWindow(acQuery, pvObjectName) If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable ' FormOperations returns <Null> in OpenOffice Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor Case acDataTable Set oWindow = _SelectWindow(acTable, pvObjectName) If IsNull(oWindow.Frame.Controller.FormOperations) Then Goto Error_NotApplicable Set oResultSet = oWindow.Frame.Controller.FormOperations.Cursor Case Else End Select ' Check if current row updated => Save it If oResultSet.IsNew Then oResultSet.insertRow() ElseIf oResultSet.IsModified Then oResultSet.updateRow() End If lOffset = pvOffset Select Case pvRecord Case acFirst : GoToRecord = oResultSet.first() Case acGoTo : GoToRecord = oResultSet.absolute(lOffset) Case acLast : GoToRecord = oResultSet.last() Case acNewRec oResultSet.last() ' To simulate the behaviour in the UI oResultSet.moveToInsertRow() GoToRecord = True Case acNext If lOffset = 1 Then GoToRecord = oResultSet.next() Else GoToRecord = oResultSet.relative(lOffset) End If Case acPrevious If lOffset = 1 Then GoToRecord = oResultSet.previous() Else GoToRecord = oResultSet.relative(- lOffset) End If End Select Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_Target: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(2, pvObjectName)) Goto Exit_Function Error_Offset: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(4, pvOffset)) Goto Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function End Function ' GoToRecord REM ----------------------------------------------------------------------------------------------------------------------- Public Function Maximize() As Boolean ' Maximize the window having the focus Utils._SetCalledSub("Maximize") Dim oWindow As Object Maximize = False Set oWindow = _SelectWindow() If Not IsNull(oWindow.Frame) Then If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMaximized") Then oWindow.Frame.ContainerWindow.IsMaximized = True ' Ignored when <= OO3.2 Maximize = True End If Utils._ResetCalledSub("Maximize") Exit Function End Function ' Maximize V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Minimize() As Boolean ' Maximize the form having the focus Utils._SetCalledSub("Minimize") Dim oWindow As Object Minimize = False Set oWindow = _SelectWindow() If Not IsNull(oWindow.Frame) Then If Utils._hasUNOProperty(oWindow.Frame.ContainerWindow, "IsMinimized") Then oWindow.Frame.ContainerWindow.IsMinimized = True Minimize = True End If Utils._ResetCalledSub("Minimize") Exit Function End Function ' Minimize V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function MoveSize(ByVal Optional pvLeft As Variant _ , ByVal Optional pvTop As Variant _ , ByVal Optional pvWidth As Variant _ , ByVal Optional pvHeight As Variant _ ) As Variant ' Execute MoveSize action If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("MoveSize") MoveSize = False If IsMissing(pvLeft) Then pvLeft = -1 If IsMissing(pvTop) Then pvTop = -1 If IsMissing(pvWidth) Then pvWidth = -1 If IsMissing(pvHeight) Then pvHeight = -1 If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function Dim iArg As Integer, iWrong As Integer ' Check arguments values iArg = 0 If pvHeight < -1 Then iArg = 4 : iWrong = pvHeight ElseIf pvWidth < -1 Then iArg = 3 : iWrong = pvWidth ElseIf pvTop < -1 Then iArg = 2 : iWrong = pvTop ElseIf pvLeft < -1 Then iArg = 1 : iWrong = pvLeft End If If iArg > 0 Then TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArg, iWrong)) Goto Exit_Function End If Dim iPosSize As Integer iPosSize = 0 If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT Dim oWindow As Object Set oWindow = _SelectWindow() With oWindow If Not IsNull(.Frame) Then If Utils._hasUNOProperty(.Frame.ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 .Frame.ContainerWindow.IsMaximized = False .Frame.ContainerWindow.IsMinimized = False End If .Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) MoveSize = True End If End With Exit_Function: Utils._ResetCalledSub("MoveSize") Exit Function Error_Function: TraceError(TRACEABORT, Err, "MoveSize", Erl) GoTo Exit_Function End Function ' MoveSize V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenForm(Optional ByVal pvFormName As Variant _ , Optional ByVal pvView As Variant _ , Optional ByVal pvFilterName As Variant _ , Optional ByVal pvWhereCondition As Variant _ , Optional ByVal pvDataMode As Variant _ , Optional ByVal pvWindowMode As Variant _ , Optional ByVal pvOpenArgs As Variant _ ) As Variant If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OpenForm") If IsMissing(pvFormName) Then Call _TraceArguments() If IsMissing(pvView) Then pvView = acNormal If IsMissing(pvFilterName) Then pvFilterName = "" If IsMissing(pvWhereCondition) Then pvWhereCondition = "" If IsMissing(pvDataMode) Then pvDataMode = acFormPropertySettings If IsMissing(pvWindowMode) Then pvWindowMode = acWindowNormal If IsMissing(pvOpenArgs) Then pvOpenArgs = "" Set OpenForm = Nothing If Not (Utils._CheckArgument(pvFormName, 1, vbString) _ And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acNormal, acPreview, acDesign)) _ And Utils._CheckArgument(pvFilterName, 3, vbString) _ And Utils._CheckArgument(pvWhereCondition, 4, vbString) _ And Utils._CheckArgument(pvDataMode, 5, Utils._AddNumeric(), Array(acFormAdd, acFormEdit, acFormPropertySettings, acFormReadOnly)) _ And Utils._CheckArgument(pvWindowMode, 6, Utils._AddNumeric(), Array(acDialog, acHidden, acIcon, acWindowNormal)) _ ) Then Goto Exit_Function Dim ofForm As Object, sWarning As String Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Set ofForm = Application.AllForms(pvFormName) If ofForm.IsLoaded Then sWarning = _GetLabel("ERR" & ERRFORMYETOPEN) sWarning = Join(Split(sWarning, "%0"), ofForm._Name) TraceLog(TRACEANY, "OpenForm: " & sWarning) Set OpenForm = ofForm Goto Exit_Function End If ' Open the form Select Case pvView Case acNormal, acPreview: bOpenMode = False Case acDesign : bOpenMode = True End Select Set oController = oDatabase.Document.CurrentController Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode) ' Apply the filters (FilterName) AND (WhereCondition) Dim sFilter As String, oForm As Object, oFormsCollection As Object If pvFilterName = "" And pvWhereCondition = "" Then sFilter = "" ElseIf pvFilterName = "" Or pvWhereCondition = "" Then sFilter = pvFilterName & pvWhereCondition Else sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")" End If Set oFormsCollection = oOpenForm.DrawPage.Forms If oFormsCollection.getCount() > 0 Then Set oForm = oFormsCollection.getByIndex(0) Else Set oForm = Nothing If Not IsNull(oForm) Then If sFilter <> "" Then oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter) oForm.ApplyFilter = True oForm.reload() ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed oForm.Filter = "" oForm.ApplyFilter = False oForm.reload() End If End If 'Housekeeping Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open With ofForm If Not IsNull(.DatabaseForm) Then Select Case pvDataMode Case acFormAdd .AllowAdditions = True .AllowDeletions = False .AllowEdits = False Case acFormEdit .AllowAdditions = True .AllowDeletions = True .AllowEdits = True Case acFormReadOnly .AllowAdditions = False .AllowDeletions = False .AllowEdits = False Case acFormPropertySettings End Select End If .Visible = ( pvWindowMode <> acHidden ) ._OpenArgs = pvOpenArgs 'To avoid AOO 3.4 bug See http://user.services.openoffice.org/en/forum/viewtopic.php?f=13&t=53751 .Component.CurrentController.ViewSettings.ShowOnlineLayout = True End With Set OpenForm = ofForm Exit_Function: Utils._ResetCalledSub("OpenForm") Set ofForm = Nothing Set oOpenForm = Nothing Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenForm", Erl) Set OpenForm = Nothing GoTo Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1) Goto Exit_Function Trace_Error: TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName) Set OpenForm = Nothing Goto Exit_Function End Function ' OpenForm V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenQuery(Optional ByVal pvQueryName As Variant _ , Optional ByVal pvView As Variant _ , Optional ByVal pvDataMode As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OpenQuery") If IsMissing(pvQueryName) Then Call _TraceArguments() If IsMissing(pvView) Then pvView = acViewNormal If IsMissing(pvDataMode) Then pvDataMode = acEdit OpenQuery = DoCmd._OpenObject("Query", pvQueryName, pvView, pvDataMode) Exit_Function: Utils._ResetCalledSub("OpenQuery") Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenQuery", Erl) GoTo Exit_Function End Function ' OpenQuery REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenReport(Optional ByVal pvReportName As Variant _ , Optional ByVal pvView As Variant _ , Optional ByVal pvDataMode As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OpenReport") If IsMissing(pvReportName) Then Call _TraceArguments() If IsMissing(pvView) Then pvView = acViewNormal If IsMissing(pvDataMode) Then pvDataMode = acEdit OpenReport = DoCmd._OpenObject("Report", pvReportName, pvView, pvDataMode) Exit_Function: Utils._ResetCalledSub("OpenReport") Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenReport", Erl) GoTo Exit_Function End Function ' OpenReport REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenSQL(Optional ByVal pvSQL As Variant _ , Optional ByVal pvOption As Variant _ ) As Boolean ' Return True if the execution of the SQL statement was successful ' SQL must contain a SELECT query ' pvOption can force pass through mode If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OpenSQL") OpenSQL = False If IsMissing(pvSQL) Then Call _TraceArguments() If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function Const cstNull = -1 If IsMissing(pvOption) Then pvOption = cstNull Else If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function End If OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption) Exit_Function: Utils._ResetCalledSub("OpenSQL") Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenSQL", Erl) GoTo Exit_Function End Function ' OpenSQL V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenTable(Optional ByVal pvTableName As Variant _ , Optional ByVal pvView As Variant _ , Optional ByVal pvDataMode As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OpenTable") If IsMissing(pvTableName) Then Call _TraceArguments() If IsMissing(pvView) Then pvView = acViewNormal If IsMissing(pvDataMode) Then pvDataMode = acEdit OpenTable = DoCmd._OpenObject("Table", pvTableName, pvView, pvDataMode) Exit_Function: Utils._ResetCalledSub("OpenTable") Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenTable", Erl) GoTo Exit_Function End Function ' OpenTable REM ----------------------------------------------------------------------------------------------------------------------- Public Function OutputTo(ByVal pvObjectType As Variant _ , ByVal Optional pvObjectName As Variant _ , ByVal Optional pvOutputFormat As Variant _ , ByVal Optional pvOutputFile As Variant _ , ByVal Optional pvAutoStart As Variant _ , ByVal Optional pvTemplateFile As Variant _ , ByVal Optional pvEncoding As Variant _ , ByVal Optional pvQuality As Variant _ ) As Boolean REM https://wiki.openoffice.org/wiki/Framework/Article/Filter/FilterList_OOo_3_0 REM https://wiki.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options REM https://msdn.microsoft.com/en-us/library/ms709353%28v=vs.85%29.aspx 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms ' acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT for tables and queries If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "OutputTo" Utils._SetCalledSub(cstThisSub) OutputTo = False If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputForm)) Then Goto Exit_Function If IsMissing(pvObjectName) Then pvObjectName = "" If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function If IsMissing(pvOutputFormat) Then pvOutputFormat = "" If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function If pvOutputFormat <> "" Then If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _ , UCase(acFormatODS), UCase(acFormatXLS), UCase(acFormatXLSX), UCase(acFormatTXT) _ , "PDF", "ODT", "DOC", "HTML", "ODS", "XLS", "XLSX", "TXT", "CSV", "" _ )) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity End If If IsMissing(pvOutputFile) Then pvOutputFile = "" If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function If IsMissing(pvAutoStart) Then pvAutoStart = False If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function If IsMissing(pvTemplateFile) Then pvTemplateFile = "" If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function If IsMissing(pvEncoding) Then pvEncoding = 0 If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function If pvObjectType = acOutputTable Or pvObjectType = acOutputQuery Then OutputTo = Application._CurrentDb().OutputTo( _ pvObjectType _ , pvObjectName _ , pvOutputFormat _ , pvOutputFile _ , pvAutoStart _ , pvTemplateFile _ , pvEncoding _ , pvQuality _ ) GoTo Exit_Function End If Dim vWindow As Variant, sOutputFile As String, ofForm As Object, i As Integer, bFound As Boolean 'Find applicable form If pvObjectName = "" Then vWindow = _SelectWindow() If vWindow.WindowType <> acOutoutForm Then Goto Error_Action Set ofForm = Application.Forms(vWindow._Name) Else bFound = False For i = 0 To Application.Forms()._Count - 1 Set ofForm = Application.Forms(i) If UCase(ofForm._Name) = UCase(pvObjectName) Then bFound = True Exit For End If Next i If Not bFound Then Goto Error_NotFound End If 'Determine format and parameters Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport As Object, sSuffix As String If pvOutputFormat = "" Then sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format If sOutputFormat = "" Then Goto Exit_Function Else sOutputFormat = UCase(pvOutputFormat) End If Select Case sOutputFormat Case UCase(acFormatPDF), "PDF" sFilter = acFormatPDF oFilterData = Array( _ _MakePropertyValue ("ExportFormFields", False), _ ) sSuffix = "pdf" Case UCase(acFormatDOC), "DOC" sFilter = acFormatDOC oFilterData = Array() sSuffix = "doc" Case UCase(acFormatODT), "ODT" sFilter = acFormatODT oFilterData = Array() sSuffix = "odt" Case UCase(acFormatHTML), "HTML" sFilter = acFormatHTML oFilterData = Array() sSuffix = "html" End Select oExport = Array( _ _MakePropertyValue("Overwrite", True), _ _MakePropertyValue("FilterName", sFilter), _ _MakePropertyValue("FilterData", oFilterData), _ ) 'Determine output file If pvOutputFile = "" Then ' Prompt file picker to user sOutputFile = _PromptFilePicker(sSuffix) If sOutputFile = "" Then Goto Exit_Function Else sOutputFile = pvOutputFile End If sOutputFile = ConvertToURL(sOutputFile) 'Create file On Local Error Goto Error_File ofForm.Component.storeToURL(sOutputFile, oExport) On Local Error Goto Error_Function 'Launch application, if requested If pvAutoStart Then Call _ShellExecute(sOutputFile) OutputTo = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Action: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_File: TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile) GoTo Exit_Function End Function ' OutputTo V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Quit(Optional ByVal pvSave As Variant) As Variant ' Quit the application ' Modified from Andrew Pitonyak's Base Macro Programming §5.8.1 If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "Quit" Utils._SetCalledSub(cstThisSub) If IsMissing(pvSave) Then pvSave = acQuitSaveAll If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _ Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _ ) Then Goto Exit_Function Dim oDatabase As Object, oDoc As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable If Not IsNull(oDatabase) Then Set oDoc = oDatabase.Document Select Case pvSave Case acQuitPrompt If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function Case acQuitSaveNone oDoc.setModified(False) Case Else End Select If HasUnoInterfaces(oDoc, "com.sun.star.util.XCloseable") Then If (oDoc.isModified) Then If (oDoc.hasLocation AND (Not oDoc.isReadOnly)) Then oDoc.store() End If End If oDoc.close(true) Else oDoc.dispose() End If End If Exit_Function: Utils._ResetCalledSub(cstThisSub) Set oDatabase = Nothing Set oDoc = Nothing Exit Function Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) Set OpenForm = Nothing GoTo Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function End Function ' Quit V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub RunApp(Optional ByVal pvCommandLine As Variant) ' Convert to URL and execute the Command Line If _ErrorHandler() Then On Local Error Goto Error_Sub Utils._SetCalledSub("RunApp") If IsMissing(pvCommandLine) Then Call _TraceArguments() If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub _ShellExecute(ConvertToURL(pvCommandLine)) Exit_Sub: Utils._ResetCalledSub("RunApp") Exit Sub Error_Sub: TraceError(TRACEABORT, Err, "RunApp", Erl) GoTo Exit_Sub End Sub ' RunApp V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function RunCommand(Optional pvCommand As Variant, Optional pbReturnCommand As Boolean) As Variant ' Execute command via DispatchHelper ' pbReturnCommand = internal parameter to only return the exact command string (always absent if uno prefix present in pvCommand) If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort Const cstThisSub = "RunCommand" Utils._SetCalledSub(cstThisSub) Dim iVBACommand As Integer, sOOCommand As String, sDispatch As String If IsMissing(pvCommand) Then Call _TraceArguments() If Not ( Utils._CheckArgument(pvCommand, 1, Utils._AddNumeric(vbString)) ) Then Goto Exit_Function If IsMissing(pbReturnCommand) Then pbReturnCommand = False RunCommand = True Const cstUnoPrefix = ".uno:" If VarType(pvCommand) = vbString Then sOOCommand = pvCommand iVBACommand = -1 If _IsLeft(sOOCommand, cstUnoPrefix) Then Call _DispatchCommand(sOOCommand) Goto Exit_Function End If Else sOOCommand = "" iVBACommand = pvCommand End If Select Case True Case iVBACommand = acCmdAboutMicrosoftAccess Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" Case iVBACommand = acCmdAboutOpenOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" Case iVBACommand = acCmdAboutLibreOffice Or UCase(sOOCommand) = "ABOUT" : sDispatch = "About" Case UCase(sOOCommand) = "ACTIVEHELP" : sDispatch = "ActiveHelp" Case UCase(sOOCommand) = "ADDDIRECT" : sDispatch = "AddDirect" Case UCase(sOOCommand) = "ADDFIELD" : sDispatch = "AddField" Case UCase(sOOCommand) = "AUTOCONTROLFOCUS" : sDispatch = "AutoControlFocus" Case UCase(sOOCommand) = "AUTOFILTER" : sDispatch = "AutoFilter" Case UCase(sOOCommand) = "AUTOPILOTADDRESSDATASOURCE" : sDispatch = "AutoPilotAddressDataSource" Case UCase(sOOCommand) = "BASICBREAK" : sDispatch = "BasicBreak" Case iVBACommand = acCmdVisualBasicEditor Or UCase(sOOCommand) = "BASICIDEAPPEAR" : sDispatch = "BasicIDEAppear" Case UCase(sOOCommand) = "BASICSTOP" : sDispatch = "BasicStop" Case iVBACommand = acCmdBringToFront Or UCase(sOOCommand) = "BRINGTOFRONT" : sDispatch = "BringToFront" Case UCase(sOOCommand) = "CHECKBOX" : sDispatch = "CheckBox" Case UCase(sOOCommand) = "CHOOSEMACRO" : sDispatch = "ChooseMacro" Case iVBACommand = acCmdClose Or UCase(sOOCommand) = "CLOSEDOC" : sDispatch = "CloseDoc" Case UCase(sOOCommand) = "CLOSEWIN" : sDispatch = "CloseWin" Case iVBACommand = acCmdToolbarsCustomize Or UCase(sOOCommand) = "CONFIGUREDIALOG" : sDispatch = "ConfigureDialog" Case UCase(sOOCommand) = "CONTROLPROPERTIES" : sDispatch = "ControlProperties" Case iVBACommand = acCmdChangeToCommandButton Or UCase(sOOCommand) = "CONVERTTOBUTTON" : sDispatch = "ConvertToButton" Case iVBACommand = acCmdChangeToCheckBox Or UCase(sOOCommand) = "CONVERTTOCHECKBOX" : sDispatch = "ConvertToCheckBox" Case iVBACommand = acCmdChangeToComboBox Or UCase(sOOCommand) = "CONVERTTOCOMBO" : sDispatch = "ConvertToCombo" Case UCase(sOOCommand) = "CONVERTTOCURRENCY" : sDispatch = "ConvertToCurrency" Case UCase(sOOCommand) = "CONVERTTODATE" : sDispatch = "ConvertToDate" Case iVBACommand = acCmdChangeToTextBox Or UCase(sOOCommand) = "CONVERTTOEDIT" : sDispatch = "ConvertToEdit" Case UCase(sOOCommand) = "CONVERTTOFILECONTROL" : sDispatch = "ConvertToFileControl" Case iVBACommand = acCmdChangeToLabel Or UCase(sOOCommand) = "CONVERTTOFIXED" : sDispatch = "ConvertToFixed" Case UCase(sOOCommand) = "CONVERTTOFORMATTED" : sDispatch = "ConvertToFormatted" Case UCase(sOOCommand) = "CONVERTTOGROUP" : sDispatch = "ConvertToGroup" Case UCase(sOOCommand) = "CONVERTTOIMAGEBTN" : sDispatch = "ConvertToImageBtn" Case iVBACommand = acCmdChangeToImage Or UCase(sOOCommand) = "CONVERTTOIMAGECONTROL" : sDispatch = "ConvertToImageControl" Case iVBACommand = acCmdChangeToListBox Or UCase(sOOCommand) = "CONVERTTOLIST" : sDispatch = "ConvertToList" Case UCase(sOOCommand) = "CONVERTTONAVIGATIONBAR" : sDispatch = "ConvertToNavigationBar" Case UCase(sOOCommand) = "CONVERTTONUMERIC" : sDispatch = "ConvertToNumeric" Case UCase(sOOCommand) = "CONVERTTOPATTERN" : sDispatch = "ConvertToPattern" Case iVBACommand = acCmdChangeToOptionButton Or UCase(sOOCommand) = "CONVERTTORADIO" : sDispatch = "ConvertToRadio" Case UCase(sOOCommand) = "CONVERTTOSCROLLBAR" : sDispatch = "ConvertToScrollBar" Case UCase(sOOCommand) = "CONVERTTOSPINBUTTON" : sDispatch = "ConvertToSpinButton" Case UCase(sOOCommand) = "CONVERTTOTIME" : sDispatch = "ConvertToTime" Case iVBACommand = acCmdCopy Or UCase(sOOCommand) = "COPY" : sDispatch = "Copy" Case UCase(sOOCommand) = "CURRENCYFIELD" : sDispatch = "CurrencyField" Case iVBACommand = acCmdCut Or UCase(sOOCommand) = "CUT" : sDispatch = "Cut" Case UCase(sOOCommand) = "DATEFIELD" : sDispatch = "DateField" Case iVBACommand = acCmdCreateRelationship Or UCase(sOOCommand) = "DBADDRELATION " : sDispatch = "DBAddRelation " Case UCase(sOOCommand) = "DBCONVERTTOVIEW " : sDispatch = "DBConvertToView " Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DBDELETE " : sDispatch = "DBDelete " Case UCase(sOOCommand) = "DBDIRECTSQL " : sDispatch = "DBDirectSQL " Case UCase(sOOCommand) = "DBDSADVANCEDSETTINGS " : sDispatch = "DBDSAdvancedSettings " Case UCase(sOOCommand) = "DBDSCONNECTIONTYPE " : sDispatch = "DBDSConnectionType " Case iVBACommand = acCmdDatabaseProperties Or UCase(sOOCommand) = "DBDSPROPERTIES " : sDispatch = "DBDSProperties " Case UCase(sOOCommand) = "DBEDIT " : sDispatch = "DBEdit " Case iVBACommand = acCmdSQLView Or UCase(sOOCommand) = "DBEDITSQLVIEW " : sDispatch = "DBEditSqlView " Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBFORMDELETE " : sDispatch = "DBFormDelete " Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBFORMEDIT " : sDispatch = "DBFormEdit " Case iVBACommand = acCmdFormView Or UCase(sOOCommand) = "DBFORMOPEN " : sDispatch = "DBFormOpen " Case UCase(sOOCommand) = "DBFORMRENAME " : sDispatch = "DBFormRename " Case iVBACommand = acCmdNewObjectForm Or UCase(sOOCommand) = "DBNEWFORM " : sDispatch = "DBNewForm " Case UCase(sOOCommand) = "DBNEWFORMAUTOPILOT " : sDispatch = "DBNewFormAutoPilot " Case UCase(sOOCommand) = "DBNEWQUERY " : sDispatch = "DBNewQuery " Case UCase(sOOCommand) = "DBNEWQUERYAUTOPILOT " : sDispatch = "DBNewQueryAutoPilot " Case UCase(sOOCommand) = "DBNEWQUERYSQL " : sDispatch = "DBNewQuerySql " Case UCase(sOOCommand) = "DBNEWREPORT " : sDispatch = "DBNewReport " Case UCase(sOOCommand) = "DBNEWREPORTAUTOPILOT " : sDispatch = "DBNewReportAutoPilot " Case iVBACommand = acCmdNewObjectTable Or UCase(sOOCommand) = "DBNEWTABLE " : sDispatch = "DBNewTable " Case UCase(sOOCommand) = "DBNEWTABLEAUTOPILOT " : sDispatch = "DBNewTableAutoPilot " Case iVBACommand = acCmdNewObjectView Or UCase(sOOCommand) = "DBNEWVIEW " : sDispatch = "DBNewView " Case UCase(sOOCommand) = "DBNEWVIEWSQL " : sDispatch = "DBNewViewSQL " Case iVBACommand = acCmdOpenDatabase Or UCase(sOOCommand) = "DBOPEN " : sDispatch = "DBOpen " Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBQUERYDELETE " : sDispatch = "DBQueryDelete " Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBQUERYEDIT " : sDispatch = "DBQueryEdit " Case iVBACommand = acCmdNewObjectQuery Or UCase(sOOCommand) = "DBQUERYOPEN " : sDispatch = "DBQueryOpen " Case UCase(sOOCommand) = "DBQUERYRENAME " : sDispatch = "DBQueryRename " Case UCase(sOOCommand) = "DBREFRESHTABLES " : sDispatch = "DBRefreshTables " Case iVBACommand = acCmdShowAllRelationships Or UCase(sOOCommand) = "DBRELATIONDESIGN " : sDispatch = "DBRelationDesign " Case UCase(sOOCommand) = "DBRENAME " : sDispatch = "DBRename " Case iVBACommand = acCmdRemove Or UCase(sOOCommand) = "DBREPORTDELETE " : sDispatch = "DBReportDelete " Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBREPORTEDIT " : sDispatch = "DBReportEdit " Case iVBACommand = acCmdNewObjectReport Or UCase(sOOCommand) = "DBREPORTOPEN " : sDispatch = "DBReportOpen " Case UCase(sOOCommand) = "DBREPORTRENAME " : sDispatch = "DBReportRename " Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "DBSELECTALL " : sDispatch = "DBSelectAll " Case UCase(sOOCommand) = "DBSHOWDOCINFOPREVIEW " : sDispatch = "DBShowDocInfoPreview " Case UCase(sOOCommand) = "DBSHOWDOCPREVIEW " : sDispatch = "DBShowDocPreview " Case iVBACommand = acCmdRemoveTable Or UCase(sOOCommand) = "DBTABLEDELETE " : sDispatch = "DBTableDelete " Case iVBACommand = acCmdDesignView Or UCase(sOOCommand) = "DBTABLEEDIT " : sDispatch = "DBTableEdit " Case UCase(sOOCommand) = "DBTABLEFILTER " : sDispatch = "DBTableFilter " Case iVBACommand = acCmdOpenTable Or UCase(sOOCommand) = "DBTABLEOPEN " : sDispatch = "DBTableOpen " Case iVBACommand = acCmdRename Or UCase(sOOCommand) = "DBTABLERENAME " : sDispatch = "DBTableRename " Case UCase(sOOCommand) = "DBUSERADMIN " : sDispatch = "DBUserAdmin " Case UCase(sOOCommand) = "DBVIEWFORMS " : sDispatch = "DBViewForms " Case UCase(sOOCommand) = "DBVIEWQUERIES " : sDispatch = "DBViewQueries " Case UCase(sOOCommand) = "DBVIEWREPORTS " : sDispatch = "DBViewReports " Case UCase(sOOCommand) = "DBVIEWTABLES " : sDispatch = "DBViewTables " Case iVBACommand = acCmdDelete Or UCase(sOOCommand) = "DELETE" : sDispatch = "Delete" Case iVBACommand = acCmdDeleteRecord Or UCase(sOOCommand) = "DELETERECORD" : sDispatch = "DeleteRecord" Case UCase(sOOCommand) = "DESIGNERDIALOG" : sDispatch = "DesignerDialog" Case UCase(sOOCommand) = "EDIT" : sDispatch = "Edit" Case UCase(sOOCommand) = "FIRSTRECORD" : sDispatch = "FirstRecord" Case UCase(sOOCommand) = "FONTDIALOG" : sDispatch = "FontDialog" Case UCase(sOOCommand) = "FONTHEIGHT" : sDispatch = "FontHeight" Case UCase(sOOCommand) = "FORMATTEDFIELD" : sDispatch = "FormattedField" Case UCase(sOOCommand) = "FORMFILTER" : sDispatch = "FormFilter" Case iVBACommand = acCmdApplyFilterSort Or UCase(sOOCommand) = "FORMFILTERED" : sDispatch = "FormFiltered" Case UCase(sOOCommand) = "FORMFILTEREXECUTE" : sDispatch = "FormFilterExecute" Case UCase(sOOCommand) = "FORMFILTEREXIT" : sDispatch = "FormFilterExit" Case UCase(sOOCommand) = "FORMFILTERNAVIGATOR" : sDispatch = "FormFilterNavigator" Case UCase(sOOCommand) = "FORMPROPERTIES" : sDispatch = "FormProperties" Case UCase(sOOCommand) = "FULLSCREEN" : sDispatch = "FullScreen" Case UCase(sOOCommand) = "GALLERY" : sDispatch = "Gallery" Case UCase(sOOCommand) = "GRID" : sDispatch = "Grid" Case iVBACommand = acCmdSnapToGrid Or UCase(sOOCommand) = "GRIDUSE" : sDispatch = "GridUse" Case iVBACommand = acCmdViewGrid Or UCase(sOOCommand) = "GRIDVISIBLE" : sDispatch = "GridVisible" Case UCase(sOOCommand) = "GROUPBOX" : sDispatch = "GroupBox" Case UCase(sOOCommand) = "HELPINDEX" : sDispatch = "HelpIndex" Case UCase(sOOCommand) = "HELPSUPPORT" : sDispatch = "HelpSupport" Case iVBACommand = acCmdInsertHyperlink Or UCase(sOOCommand) = "HYPERLINKDIALOG" : sDispatch = "HyperlinkDialog" Case UCase(sOOCommand) = "IMAGEBUTTON" : sDispatch = "Imagebutton" Case UCase(sOOCommand) = "IMAGECONTROL" : sDispatch = "ImageControl" Case UCase(sOOCommand) = "LABEL" : sDispatch = "Label" Case iVBACommand = acCmdMaximumRecords Or UCase(sOOCommand) = "LASTRECORD" : sDispatch = "LastRecord" Case UCase(sOOCommand) = "LISTBOX" : sDispatch = "ListBox" Case UCase(sOOCommand) = "MACRODIALOG" : sDispatch = "MacroDialog" Case UCase(sOOCommand) = "MACROORGANIZER" : sDispatch = "MacroOrganizer" Case UCase(sOOCommand) = "NAVIGATIONBAR" : sDispatch = "NavigationBar" Case iVBACommand = acCmdObjectBrowser Or UCase(sOOCommand) = "NAVIGATOR" : sDispatch = "Navigator" Case UCase(sOOCommand) = "NEWDOC" : sDispatch = "NewDoc" Case UCase(sOOCommand) = "NEWRECORD" : sDispatch = "NewRecord" Case UCase(sOOCommand) = "NEXTRECORD" : sDispatch = "NextRecord" Case UCase(sOOCommand) = "NUMERICFIELD" : sDispatch = "NumericField" Case UCase(sOOCommand) = "OPEN" : sDispatch = "Open" Case UCase(sOOCommand) = "OPTIONSTREEDIALOG" : sDispatch = "OptionsTreeDialog" Case UCase(sOOCommand) = "ORGANIZER" : sDispatch = "Organizer" Case UCase(sOOCommand) = "PARAGRAPHDIALOG" : sDispatch = "ParagraphDialog" Case iVBACommand = acCmdPaste Or UCase(sOOCommand) = "PASTE" : sDispatch = "Paste" Case iVBACommand = acCmdPasteSpecial Or UCase(sOOCommand) = "PASTESPECIAL " : sDispatch = "PasteSpecial " Case UCase(sOOCommand) = "PATTERNFIELD" : sDispatch = "PatternField" Case UCase(sOOCommand) = "PREVRECORD" : sDispatch = "PrevRecord" Case iVBACommand = acCmdPrint Or UCase(sOOCommand) = "PRINT" : sDispatch = "Print" Case UCase(sOOCommand) = "PRINTDEFAULT" : sDispatch = "PrintDefault" Case UCase(sOOCommand) = "PRINTERSETUP" : sDispatch = "PrinterSetup" Case iVBACommand = acCmdPrintPreview Or UCase(sOOCommand) = "PRINTPREVIEW" : sDispatch = "PrintPreview" Case UCase(sOOCommand) = "PUSHBUTTON" : sDispatch = "Pushbutton" Case UCase(sOOCommand) = "QUIT" : sDispatch = "Quit" Case UCase(sOOCommand) = "RADIOBUTTON" : sDispatch = "RadioButton" Case iVBACommand = acCmdSaveRecord Or UCase(sOOCommand) = "RECSAVE" : sDispatch = "RecSave" Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "RECSEARCH" : sDispatch = "RecSearch" Case iVBACommand = acCmdUndo Or UCase(sOOCommand) = "RECUNDO" : sDispatch = "RecUndo" Case iVBACommand = acCmdRefresh Or UCase(sOOCommand) = "REFRESH" : sDispatch = "Refresh" Case UCase(sOOCommand) = "RELOAD" : sDispatch = "Reload" Case iVBACommand = acCmdRemoveFilterSort Or UCase(sOOCommand) = "REMOVEFILTERSORT" : sDispatch = "RemoveFilterSort" Case iVBACommand = acCmdRunMacro Or UCase(sOOCommand) = "RUNMACRO" : sDispatch = "RunMacro" Case iVBACommand = acCmdSave Or UCase(sOOCommand) = "SAVE" : sDispatch = "Save" Case UCase(sOOCommand) = "SAVEALL" : sDispatch = "SaveAll" Case iVBACommand = acCmdSaveAs Or UCase(sOOCommand) = "SAVEAS" : sDispatch = "SaveAs" Case UCase(sOOCommand) = "SAVEBASICAS" : sDispatch = "SaveBasicAs" Case UCase(sOOCommand) = "SCRIPTORGANIZER" : sDispatch = "ScriptOrganizer" Case UCase(sOOCommand) = "SCROLLBAR" : sDispatch = "ScrollBar" Case iVBACommand = acCmdFind Or UCase(sOOCommand) = "SEARCHDIALOG" : sDispatch = "SearchDialog" Case iVBACommand = acCmdSelectAll Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll" Case iVBACommand = acCmdSelectAllRecords Or UCase(sOOCommand) = "SELECTALL" : sDispatch = "SelectAll" Case iVBACommand = acCmdSendToBack Or UCase(sOOCommand) = "SENDTOBACK" : sDispatch = "SendToBack" Case UCase(sOOCommand) = "SHOWFMEXPLORER" : sDispatch = "ShowFmExplorer" Case UCase(sOOCommand) = "SIDEBAR" : sDispatch = "Sidebar" Case iVBACommand = acCmdSortDescending Or UCase(sOOCommand) = "SORTDOWN" : sDispatch = "SortDown" Case iVBACommand = acCmdSortAscending Or UCase(sOOCommand) = "SORTUP" : sDispatch = "Sortup" Case UCase(sOOCommand) = "SPINBUTTON" : sDispatch = "SpinButton" Case UCase(sOOCommand) = "STATUSBARVISIBLE" : sDispatch = "StatusBarVisible" Case UCase(sOOCommand) = "SWITCHCONTROLDESIGNMODE" : sDispatch = "SwitchControlDesignMode" Case iVBACommand = acCmdTabOrder Or UCase(sOOCommand) = "TABDIALOG" : sDispatch = "TabDialog" Case UCase(sOOCommand) = "USEWIZARDS" : sDispatch = "UseWizards" Case UCase(sOOCommand) = "VERSIONDIALOG" : sDispatch = "VersionDialog" Case UCase(sOOCommand) = "VIEWDATASOURCEBROWSER" : sDispatch = "ViewDataSourceBrowser" Case iVBACommand = acCmdDatasheetView Or UCase(sOOCommand) = "VIEWFORMASGRID" : sDispatch = "ViewFormAsGrid" Case iVBACommand = acCmdZoomSelection Or UCase(sOOCommand) = "ZOOM" : sDispatch = "Zoom" Case Else If iVBACommand >= 0 Then Goto Exit_Function sDispatch = pvCommand End Select If pbReturnCommand Then RunCommand = cstUnoPrefix & sDispatch Else Call _DispatchCommand(cstUnoPrefix & sDispatch) Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) GoTo Exit_Function End Function ' RunCommand V0.7.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function RunSQL(Optional ByVal pvSQL As Variant _ , Optional ByVal pvOption As Variant _ ) As Boolean ' Return True if the execution of the SQL statement was successful ' SQL must contain an ACTION query If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("RunSQL") RunSQL = False If IsMissing(pvSQL) Then Call _TraceArguments() If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function Const cstNull = -1 If IsMissing(pvOption) Then pvOption = cstNull Else If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function End If RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption) Exit_Function: Utils._ResetCalledSub("RunSQL") Exit Function Error_Function: TraceError(TRACEABORT, Err, "RunSQL", Erl) GoTo Exit_Function End Function ' RunSQL V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function SelectObject( ByVal Optional pvObjectType As Variant _ , ByVal Optional pvObjectName As Variant _ , ByVal Optional pvInDatabaseWindow As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "SelectObject" Utils._SetCalledSub(cstThisSub) If IsMissing(pvObjectType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ ) Then Goto Exit_Function If IsMissing(pvObjectName) Then Select Case pvObjectType Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() Case Else End Select pvObjectName = "" Else If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function End If If Not IsMissing(pvInDatabaseWindow) Then If Not Utils._CheckArgument(pvInDatabaseWindow, 3, vbBoolean, False) Then Goto Exit_Function End If Dim oWindow As Object Set oWindow = _SelectWindow(pvObjectType, pvObjectName) If IsNull(oWindow.Frame) Then Goto Error_NotFound With oWindow.Frame.ContainerWindow If .isVisible() = False Then .setVisible(True) .IsMinimized = False .setFocus() .setEnable(True) ' Added to try to bypass desynchro issue in Linux .toFront() ' Added to force window change in Linux End With Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' SelectObject V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function SendObject(ByVal Optional pvObjectType As Variant _ , ByVal Optional pvObjectName As Variant _ , ByVal Optional pvOutputFormat As Variant _ , ByVal Optional pvTo As Variant _ , ByVal Optional pvCc As Variant _ , ByVal Optional pvBcc As Variant _ , ByVal Optional pvSubject As Variant _ , ByVal Optional pvMessageText As Variant _ , ByVal Optional pvEditMessage As Variant _ , ByVal Optional pvTemplateFile As Variant _ ) As Boolean 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms 'To be prepared: acFormatCSV and acFormatODS for tables/queries ? If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("SendObject") SendObject = False If IsMissing(pvObjectType) Then pvObjectType = acSendNoObject If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acSendNoObject, acSendForm)) Then Goto Exit_Function If IsMissing(pvObjectName) Then pvObjectName = "" If Not Utils._CheckArgument(pvObjectName, 2,vbString) Then Goto Exit_Function If IsMissing(pvOutputFormat) Then pvOutputFormat = "" If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function If pvOutputFormat <> "" Then If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _ UCase(acFormatPDF), UCase(acFormatODT), UCase(acFormatDOC), UCase(acFormatHTML) _ , "PDF", "ODT", "DOC", "HTML", "" _ )) Then Goto Exit_Function ' A 2nd time to allow case unsensitivity End If If IsMissing(pvTo) Then pvTo = "" If Not Utils._CheckArgument(pvTo, 4, vbString) Then Goto Exit_Function If IsMissing(pvCc) Then pvCc = "" If Not Utils._CheckArgument(pvCc, 5, vbString) Then Goto Exit_Function If IsMissing(pvBcc) Then pvBcc = "" If Not Utils._CheckArgument(pvBcc, 6, vbString) Then Goto Exit_Function If IsMissing(pvSubject) Then pvSubject = "" If Not Utils._CheckArgument(pvSubject, 7, vbString) Then Goto Exit_Function If IsMissing(pvMessageText) Then pvMessageText = "" If Not Utils._CheckArgument(pvMessageText, 8, vbString) Then Goto Exit_Function If IsMissing(pvEditMessage) Then pvEditMessage = True If Not Utils._CheckArgument(pvEditMessage, 9, vbBoolean) Then Goto Exit_Function If IsMissing(pvTemplateFile) Then pvTemplateFile = "" If Not Utils._CheckArgument(pvTemplateFile,10, vbString, "") Then Goto Exit_Function Dim vTo() As Variant, vCc() As Variant, vBcc() As Variant, oWindow As Object Dim sDirectory As String, sOutputFile As String, sSuffix As String, sOutputFormat As String Const cstSemiColon = ";" If pvTo <> "" Then vTo() = Split(pvTo, cstSemiColon) Else vTo() = Array() If pvCc <> "" Then vCc() = Split(pvCc, cstSemiColon) Else vCc() = Array() If pvBcc <> "" Then vBcc() = Split(pvBcc, cstSemiColon) Else vBcc() = Array() Select Case True Case pvObjectType = acSendNoObject And pvObjectName = "" SendObject = _SendWithoutAttachment(vTo, vCc, vBcc, pvSubject, pvMessageText) Case Else If pvObjectType = acSendNoObject And pvObjectName <> "" Then If Not FileExists(pvObjectName) Then Goto Error_File sOutputFile = pvObjectName Else ' OutputFile has to be created If pvObjectType <> acSendNoObject And pvObjectName = "" Then oWindow = _SelectWindow() If oWindow.WindowType <> acSendForm Then Goto Error_Action pvObjectType = acSendForm pvObjectName = oWindow._Name End If sDirectory = Utils._getTempDirectoryURL() If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/" If pvOutputFormat = "" Then sOutputFormat = _PromptFormat(Array("PDF", "ODT", "DOC", "HTML")) ' Prompt user for format If sOutputFormat = "" Then Goto Exit_Function Else sOutputFormat = UCase(pvOutputFormat) End If Select Case sOutputFormat Case UCase(acFormatPDF), "PDF" : sSuffix = "pdf" Case UCase(acFormatDOC), "DOC" : sSuffix = "doc" Case UCase(acFormatODT), "ODT" : sSuffix = "odt" Case UCase(acFormatHTML), "HTML" : sSuffix = "html" End Select sOutputFile = sDirectory & pvObjectName & "." & sSuffix If Not OutputTo(pvObjectType, pvObjectName, sOutputFormat, sOutputFile, False) Then Goto Exit_Function End If SendObject = _SendWithAttachment(vTo, vCc, vBcc, pvSubject, Array(sOutputFile), pvMessageText, pvEditMessage) End Select Exit_Function: Utils._ResetCalledSub("SendObject") Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "SendObject", Erl) GoTo Exit_Function Error_Action: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) Goto Exit_Function Error_File: TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , pvObjectName) Goto Exit_Function End Function ' SendObject V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _ , ByVal Optional pvObjectName As Variant _ , ByVal Optional pvHidden As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function SetHiddenAttribute = False Const cstThisSub = "SetHiddenAttribute" Utils._SetCalledSub(cstThisSub) If IsMissing(pvObjectType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _ ) Then Goto Exit_Function If IsMissing(pvObjectName) Then Select Case pvObjectType Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() Case Else End Select pvObjectName = "" Else If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function End If If IsMissing(pvHidden) Then pvHidden = True Else If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function End If Dim oWindow As Object Set oWindow = _SelectWindow(pvObjectType, pvObjectName) If IsNull(oWindow.Frame) Then Goto Error_NotFound oWindow.Frame.ContainerWindow.setVisible(Not pvHidden) SetHiddenAttribute = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' SetHiddenAttribute V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function SetOrderBy( _ ByVal Optional pvOrder As Variant _ , ByVal Optional pvControlName As Variant _ ) As Boolean ' Sort ann open table, query, form or subform (if pvControlName present) If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "SetOrderBy" Utils._SetCalledSub(cstThisSub) SetOrderBy = False If IsMissing(pvOrder) Then pvOrder = "" If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function If IsMissing(pvControlName) Then pvControlName = "" If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable sOrder = oDatabase._ReplaceSquareBrackets(pvOrder) Set oWindow = _SelectWindow() With oWindow Select Case .WindowType Case acForm Set oTarget = _DatabaseForm(._Name, pvControlName) Case acQuery, acTable If pvControlName <> "" Then Goto Exit_Function If IsNull(.Frame.Controller.FormOperations) Then Goto Error_NotApplicable ' FormOperations returns <Null> in OpenOffice Set oTarget = .Frame.Controller.FormOperations.Cursor Case Else ' Ignore action Goto Exit_Function End Select End With With oTarget .Order = sOrder .reload() End With SetOrderBy = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' SetOrderBy V1.2.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function ShowAllrecords() As Boolean ' Removes any existing filter that exists on the current table, query or form If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "ShowAllRecords" Utils._SetCalledSub(cstThisSub) ShowAllRecords = False Dim oWindow As Object, oDatabase As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Set oWindow = _SelectWindow() Select Case oWindow.WindowType Case acForm, acQuery, acTable RunCommand(acCmdRemoveFilterSort) ShowAllrecords = True Case Else ' Ignore action End Select Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' ShowAllrecords V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _CheckColumnType(pvFindWhat As Variant, vDataField As Variant) As Boolean ' Return true if both arguments of the same type ' vDataField is a ResultSet column Dim bFound As Boolean bFound = False With com.sun.star.sdbc.DataType Select Case vDataField.Type Case .DATE, .TIME, .TIMESTAMP If VarType(pvFindWhat) = vbDate Then bFound = True Case .TINYINT, .SMALLINT, .INTEGER, .BIGINT, .FLOAT, .REAL, .DOUBLE, .NUMERIC, .DECIMAL If Utils._InList(VarType(pvFindWhat), Utils._AddNumeric()) Then bFound = True Case .CHAR, .VARCHAR, .LONGVARCHAR If VarType(pvFindWhat) = vbString Then bFound = True Case Else End Select End With _CheckColumnType = bFound End Function ' _CheckColumnType V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Sub _ConvertDataDescriptor( ByRef poSource As Object _ , ByVal piSourceRDBMS As Integer _ , ByRef poTarget As Object _ , ByRef poDatabase As Object _ , ByVal Optional pbKey As Boolean _ ) ' Convert source column descriptor to target descriptor ' If RDMSs identical, simply move property by property ' Otherwise ' - Use Type conversion tables (cfr. DataTypes By RDBMS.ods case study) ' - Select among synonyms the entry with the lowest Precision at least >= source Precision ' - Derive TypeName and Precision values Dim vTypesReference() As Variant, vTypes() As Variant, vTypeNames() As Variant Dim i As Integer, iType As Integer, iTypeAlias As Integer Dim iNbTypes As Integer, iBestFit As Integer, lFitPrecision As Long, lPrecision As Long On Local Error Goto Error_Sub If IsMissing(pbKey) Then pbKey = False poTarget.Name = poSource.Name poTarget.Description = poSource.Description If Not pbKey Then poTarget.ControlDefault = poSource.ControlDefault poTarget.FormatKey = poSource.FormatKey poTarget.HelpText = poSource.HelpText poTarget.Hidden = poSource.Hidden End If poTarget.IsCurrency = poSource.IsCurrency poTarget.IsNullable = poSource.IsNullable poTarget.Scale = poSource.Scale If piSourceRDBMS = poDatabase._RDBMS Or poDatabase._RDBMS = DBMS_UNKNOWN Then poTarget.Type = poSource.Type poTarget.Precision = poSource.Precision poTarget.TypeName = poSource.TypeName Goto Exit_Sub End If ' Search DataType compatibility With poDatabase ' Find source datatype entry in Reference array iType = -1 For i = 0 To UBound(._ColumnTypesReference) If ._ColumnTypesReference(i) = poSource.Type Then iType = i Exit For End If Next i If iType = -1 Then Goto Error_Compatibility iTypeAlias = ._ColumnTypesAlias(iType) ' Find best choice for the datatype of the target column iNbTypes = UBound(._ColumnTypes) iBestFit = -1 lFitPrecision = -2 ' Some POSTGRES datatypes have a precision of -1 For i = 0 To iNbTypes If ._ColumnTypes(i) = iTypeAlias Then ' Minimal fit = correct datatype lPrecision = ._ColumnPrecisions(i) If iBestFit = -1 _ Or (iBestFit > -1 And poSource.Precision > 0 And lPrecision >= poSource.Precision And lPrecision < lFitPrecision) _ Or (iBestFit > -1 And poSource.Precision = 0 And lPrecision > lFitPrecision) Then ' First fit or better fit iBestFit = i lFitPrecision = lPrecision End If End If Next i If iBestFit = -1 Then Goto Error_Compatibility poTarget.Type = iTypeAlias poTarget.Precision = lFitPrecision poTarget.TypeName = ._ColumnTypeNames(iBestFit) End With Exit_Sub: Exit Sub Error_Compatibility: TraceError(TRACEFATAL, ERRCOMPATIBILITY, Utils._CalledSub(), 0, 1, poSource.Name) Goto Exit_Sub Error_Sub: TraceError(TRACEABORT, Err, "_ConvertDataDescriptor", Erl) Goto Exit_Sub End Sub ' ConvertDataDescriptor V1.6.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _DatabaseForm(psForm As String, psControl As String) 'Return DatabaseForm element of Form object (based on psForm which is known as a real form name) 'or of SubForm object (based on psControl which is checked for being a subform) Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer Dim bFound As Boolean, i As Integer, sName As String Set oForm = Application.Forms(psForm) If psControl <> "" Then ' Search subform With oForm.DatabaseForm iControlCount = .getCount() bFound = False If iControlCount > 0 Then sControls() = .getElementNames() sName = UCase(Utils._Trim(psControl)) For i = 0 To iControlCount - 1 If UCase(sControls(i)) = sName Then bFound = True Exit For End If Next i End If End With If bFound Then sName = sControls(i) Else Goto Trace_NotFound Set oControl = oForm.Controls(sName) If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound Set _DatabaseForm = oControl.Form.DatabaseForm Else Set _DatabaseForm = oForm.DatabaseForm End If Exit_Function: Exit Function Trace_NotFound: TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) Goto Exit_Function Trace_SubFormNotFound: TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) Goto Exit_Function End Function ' _DatabaseForm V1.2.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Sub _DispatchCommand(ByVal psCommand As String) ' Execute command given as argument - ".uno:" is presumed already present Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String Dim oResult As Variant Dim sCommand As String Set oDocument = _SelectWindow().Frame Set oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper") sTargetFrameName = "" oResult = oDispatcher.executeDispatch(oDocument, psCommand, sTargetFrameName, 0, oArgs()) End Sub ' _DispatchCommand V1.3.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal psLastComponent As String) As String ' Return "Forms!myForm" from "Forms!myForm!datField" and "datField" If Len(psShortcut) > Len(psLastComponent) Then _getUpperShortcut = Split(psShortcut, "!" & Utils._Surround(psLastComponent))(0) Else _getUpperShortcut = psShortcut End If End Function ' _getUpperShortcut REM ----------------------------------------------------------------------------------------------------------------------- Private Function _OpenObject(ByVal psObjectType As String _ , ByVal pvObjectName As Variant _ , ByVal pvView As Variant _ , ByVal pvDataMode As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function _OpenObject = False If Not (Utils._CheckArgument(pvObjectName, 1, vbString) _ And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _ And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _ ) Then Goto Exit_Function Dim oDatabase As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object Dim i As Integer, bFound As Boolean, lComponent As Long, oQuery As Object ' Check existence of object and find its exact (case-sensitive) name Select Case psObjectType Case "Table" sObjects = oDatabase.Connection.getTables.ElementNames() lComponent = com.sun.star.sdb.application.DatabaseObject.TABLE Case "Query" sObjects = oDatabase.Connection.getQueries.ElementNames() lComponent = com.sun.star.sdb.application.DatabaseObject.QUERY Case "Report" sObjects = oDatabase.Document.getReportDocuments.ElementNames() lComponent = com.sun.star.sdb.application.DatabaseObject.REPORT End Select bFound = False For i = 0 To UBound(sObjects) If UCase(pvObjectName) = UCase(sObjects(i)) Then sObjectName = sObjects(i) bFound = True Exit For End If Next i If Not bFound Then Goto Trace_NotFound If psObjectType = "Query" Then ' Processing for action query Set oQuery = Application._CurrentDb().QueryDefs(pvObjectName) If oQuery.pType <> dbQSelect Then _OpenObject = oQuery.Execute() GoTo Exit_Function End If End If Set oController = oDatabase.Document.CurrentController Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign )) _OpenObject = True Exit_Function: Set oObject = Nothing Set oQuery = Nothing Set oController = Nothing Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenObject", Erl) GoTo Exit_Function Trace_Error: TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) Goto Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1) Goto Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) Goto Exit_Function End Function ' _OpenObject V0.8.9 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PromptFormat(ByVal pvList As Variant) As String ' Return user selection in Format dialog Dim oDialog As Object, iOKCancel As Integer, oControl As Object Set oDialog = CreateUnoDialog(Utils._GetDialogLib().dlgFormat) oDialog.Title = _GetLabel("DLGFORMAT_TITLE") Set oControl = oDialog.Model.getByName("lblFormat") oControl.Label = _GetLabel("DLGFORMAT_LBLFORMAT_LABEL") oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP") Set oControl = oDialog.Model.getByName("cboFormat") oControl.HelpText = _GetLabel("DLGFORMAT_LBLFORMAT_HELP") Set oControl = oDialog.Model.getByName("cmdOK") oControl.Label = _GetLabel("DLGFORMAT_CMDOK_LABEL") oControl.HelpText = _GetLabel("DLGFORMAT_CMDOK_HELP") Set oControl = oDialog.Model.getByName("cmdCancel") oControl.Label = _GetLabel("DLGFORMAT_CMDCANCEL_LABEL") oControl.HelpText = _GetLabel("DLGFORMAT_CMDCANCEL_HELP") Set oControl = oDialog.Model.getByName("cboFormat") If UBound(pvList) >= 0 Then oControl.Text = pvList(0) oControl.StringItemList = pvList Else oControl.Text = "" oControl.StringItemList = Array() End If iOKCancel = oDialog.Execute() Select Case iOKCancel Case 1 ' OK _PromptFormat = oControl.Text Case 0 ' Cancel _PromptFormat = "" Case Else End Select oDialog.Dispose() End Function ' _PromptFormat V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional ByVal psWindow As String) As Object ' No argument: find active window ' 2 arguments: find corresponding window ' Return a _Window object type describing the found window Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer Dim bFound As Boolean, bActive As Boolean, sName As String, iType As Integer, sDocumentType As String Dim sImplementation As String, vLocation() As Variant Dim oWindow As _Window Dim vPersistent As Variant, oForm As Object If _ErrorHandler() Then On Local Error Goto Error_Function bActive = IsMissing(piWindowType) If IsMissing(psWindow) Then psWindow = "" Set oWindow.Frame = Nothing oWindow.DocumentType = "" If bActive Then oWindow.WindowType = acDefault oWindow._Name = "" Else oWindow.WindowType = piWindowType Select Case piWindowType Case acBasicIDE, acDatabaseWindow : oWindow._Name = "" Case Else : oWindow._Name = psWindow End Select End If iType = acDefault sDocumentType = "" Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") Set oEnum = oDesk.Components().createEnumeration Do While oEnum.hasMoreElements Set oComp = oEnum.nextElement If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = "" Select Case sImplementation Case "com.sun.star.comp.basic.BasicIDE" Set oFrame = oComp.CurrentController.Frame iType = acBasicIDE sName = "" Case "com.sun.star.comp.dba.ODatabaseDocument" Set oFrame = oComp.CurrentController.Frame iType = acDatabaseWindow sName = "" Case "SwXTextDocument" If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then Select Case oComp.Identifier Case "com.sun.star.sdb.FormDesign" ' Form iType = acForm Case "com.sun.star.sdb.TextReportDesign" ' Report iType = acReport Case "com.sun.star.text.TextDocument" ' Writer vLocation = Split(oComp.getLocation(), "/") If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = "" iType = acDocument sDocumentType = docWriter End Select If iType = acForm Then ' Identify persistent Form name vPersistent = Split(oComp.StringValue, "/") sName = _GetHierarchicalName(vPersistent(UBound(vPersistent) - 1)) ElseIf iType = acReport Then ' Identify Report name For i = 0 To UBound(oComp.Args()) If oComp.Args(i).Name = "DocumentTitle" Then sName = oComp.Args(i).Value Exit For End If Next i End If Set oFrame = oComp.CurrentController.Frame End If Case "org.openoffice.comp.dbu.ODatasourceBrowser" Set oFrame = oComp.Frame If Not IsEmpty(oComp.Selection) Then ' Empty for (F4) DatasourceBrowser !! For i = 0 To UBound(oComp.Selection()) If oComp.Selection(i).Name = "Command" Then sName = oComp.Selection(i).Value ElseIf oComp.Selection(i).Name = "CommandType" Then Select Case oComp.selection(i).Value Case com.sun.star.sdb.CommandType.TABLE iType = acTable Case com.sun.star.sdb.CommandType.QUERY iType = acQuery Case com.sun.star.sdb.CommandType.COMMAND iType = acQuery ' SQL for future use ? End Select End If Next i ' Else ignore End If Case "org.openoffice.comp.dbu.OTableDesign", "org.openoffice.comp.dbu.OQueryDesign" ' Table or Query in Edit mode If Not bActive Then If UCase(Right(oComp.Title, Len(psWindow))) = UCase(psWindow) Then ' No rigorous mean found to identify Name Set oFrame = oComp.Frame Select Case sImplementation Case "org.openoffice.comp.dbu.OTableDesign" : iType = acTable Case "org.openoffice.comp.dbu.OQueryDesign" : iType = acQuery End Select sName = Right(oComp.Title, Len(psWindow)) End If Else Set oFrame = Nothing End If Case "org.openoffice.comp.dbu.ORelationDesign" Set oFrame = oComp.Frame iType = acDiagram sName = "" Case "com.sun.star.comp.sfx2.BackingComp" ' Welcome screen Set oFrame = oComp.Frame iType = acWelcome sName = "" Case Else ' Other Calc, ..., whatever documents If Utils._hasUNOProperty(oComp, "Location") Then vLocation = Split(oComp.getLocation(), "/") If UBound(vLocation) >= 0 Then sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") Else sName = "" iType = acDocument If Utils._hasUNOProperty(oComp, "Identifier") Then Select Case oComp.Identifier Case "com.sun.star.sheet.SpreadsheetDocument" : sDocumentType = docCalc Case "com.sun.star.presentation.PresentationDocument" : sDocumentType = docImpress Case "com.sun.star.drawing.DrawingDocument" : sDocumentType = docDraw Case "com.sun.star.formula.FormulaProperties" : sDocumentType = docMath Case Else : sDocumentType = "" End Select End If Set oFrame = oComp.CurrentController.Frame End If End Select If bActive And Not IsNull(oFrame) Then If oFrame.ContainerWindow.IsActive() Then bFound = True Exit Do End If ElseIf iType = piWindowType And UCase(sName) = UCase(psWindow) Then bFound = True Exit Do End If Loop If bFound Then Set oWindow.Frame = oFrame oWindow._Name = sName oWindow.WindowType = iType oWindow.DocumentType = sDocumentType Else Set oWindow.Frame = Nothing End If Exit_Function: Set _SelectWindow = oWindow Exit Function Error_Function: TraceError(TRACEABORT, Err, "SelectWindow", Erl) GoTo Exit_Function End Function ' _SelectWindow V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _SendWithAttachment( _ ByVal pvRecipients() As Variant _ , ByVal pvCcRecipients() As Variant _ , ByVal pvBccRecipients() As Variant _ , ByVal psSubject As String _ , ByVal pvAttachments() As Variant _ , ByVal pvBody As String _ , ByVal pbEditMessage As Boolean _ ) As Boolean ' Send message with attachments If _ErrorHandler() Then On Local Error Goto Error_Function _SendWithAttachment = False Const cstWindows = 1 Const cstLinux = 4 Const cstSemiColon = ";" Dim oServiceMail as Object, oMail As Object, oMessage As Object, vFlag As Variant Dim vCc() As Variant, i As Integer, iOS As Integer, sProduct As String, bMailProvider As Boolean 'OPENOFFICE <= 3.6 and LIBREOFFICE have XSimple...Mail interface while OPENOFFICE >= 4.0 has XSystemMailProvider interface sProduct = UCase(Utils._GetProductName()) bMailProvider = ( Left(sProduct, 4) = "OPEN" And Left(_GetProductName("VERSION"), 3) >= "4.0" ) iOS = GetGuiType() Select Case iOS Case cstLinux oServiceMail = createUnoService("com.sun.star.system.SimpleCommandMail") Case cstWindows If bMailProvider Then oServiceMail = createUnoService("com.sun.star.system.SystemMailProvider") _ Else oServiceMail = createUnoService("com.sun.star.system.SimpleSystemMail") Case Else Goto Error_Mail End Select If bMailProvider Then Set oMail = oServiceMail.queryMailClient() _ Else Set oMail = oServiceMail.querySimpleMailClient() If IsNull(oMail) Then Goto Error_Mail 'Reattribute Recipients >= 2nd to ccRecipients If UBound(pvRecipients) <= 0 Then If UBound(pvCcRecipients) >= 0 Then vCc = pvCcRecipients Else ReDim vCc(0 To UBound(pvRecipients) - 1 + UBound(pvCcRecipients) + 1) For i = 0 To UBound(pvRecipients) - 1 vCc(i) = pvRecipients(i + 1) Next i For i = UBound(pvRecipients) To UBound(vCc) vCc(i) = pvCcRecipients(i - UBound(pvRecipients)) Next i End If If bMailProvider Then Set oMessage = oMail.createMailMessage() If UBound(pvRecipients) >= 0 Then oMessage.Recipient = pvRecipients(0) If psSubject <> "" Then oMessage.Subject = psSubject Select Case iOS ' Not published differences between com.sun.star.system.SimpleCommandMail and SimpleSystemMail Case cstLinux If UBound(vCc) >= 0 Then oMessage.CcRecipient = Array(Join(vCc, cstSemiColon)) If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = Array(Join(pvBccRecipients, cstSemiColon)) Case cstWindows If UBound(vCc) >= 0 Then oMessage.CcRecipient = vCc If UBound(pvBccRecipients) >= 0 Then oMessage.BccRecipient = pvBccRecipients End Select If UBound(pvAttachments) >= 0 Then oMessage.Attachement = pvAttachments If pvBody <> "" Then oMessage.Body = pvBody If pbEditMessage Then vFlag = com.sun.star.system.MailClientFlags.DEFAULTS Else vFlag = com.sun.star.system.MailClientFlags.NO_USER_INTERFACE End If oMail.sendMailMessage(oMessage, vFlag) Else Set oMessage = oMail.createSimpleMailMessage() ' Body NOT SUPPORTED ! If UBound(pvRecipients) >= 0 Then oMessage.setRecipient(pvRecipients(0)) If psSubject <> "" Then oMessage.setSubject(psSubject) Select Case iOS Case cstLinux If UBound(vCc) >= 0 Then oMessage.setCcRecipient(Array(Join(vCc, cstSemiColon))) If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(Array(Join(pvBccRecipients, cstSemiColon))) Case cstWindows If UBound(vCc) >= 0 Then oMessage.setCcRecipient(vCc) If UBound(pvBccRecipients) >= 0 Then oMessage.setBccRecipient(pvBccRecipients) End Select If UBound(pvAttachments) >= 0 Then oMessage.setAttachement(pvAttachments) If pbEditMessage Then vFlag = com.sun.star.system.SimpleMailClientFlags.DEFAULTS Else vFlag = com.sun.star.system.SimpleMailClientFlags.NO_USER_INTERFACE End If oMail.sendSimpleMailMessage(oMessage, vFlag) End If _SendWithAttachment = True Exit_Function: Exit Function Error_Function: TraceError(TRACEABORT, Err, "_SendWithAttachment", Erl) Goto Exit_Function Error_Mail: TraceError(TRACEFATAL, ERRSENDMAIL, Utils._CalledSub(), 0) Goto Exit_Function End Function ' _SendWithAttachment V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _SendWithoutAttachment(ByVal pvTo As Variant _ , ByVal pvCc As Variant _ , ByVal pvBcc As Variant _ , ByVal psSubject As String _ , ByVal psBody As String _ ) As Boolean 'Send simple message with mailto: syntax Dim sMailTo As String, sTo As String, sCc As String, sBcc As String, oDispatch As Object Const cstComma = "," If _ErrorHandler() Then On Local Error Goto Error_Function If UBound(pvTo) >= 0 Then sTo = Trim(Join(pvTo, cstComma)) Else sTo = "" If UBound(pvCc) >= 0 Then sCc = Trim(Join(pvCc, cstComma)) Else sCc = "" If UBound(pvBcc) >= 0 Then sBcc = Trim(Join(pvBcc, cstComma)) Else sBcc = "" sMailTo = "mailto:" _ & sTo & "?" _ & Iif(sCc = "", "", "cc=" & sCc & "&") _ & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _ & Iif(psSubject = "", "", "subject=" & psSubject & "&") _ & Iif(psBody = "", "", "body=" & psBody & "&") If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1) sMailTo = ConvertToUrl(sMailTo) oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper") oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array()) _SendWithoutAttachment = True Exit_Function: Exit Function Error_Function: TraceError(TRACEABORT, Err, "_SendWithoutAttachments", Erl) _SendWithoutAttachment = False Goto Exit_Function End Function ' _SendWithoutAttachment V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Private Sub _ShellExecute(sCommand As String) ' Execute shell command Dim oShell As Object Set oShell = createUnoService("com.sun.star.system.SystemShellExecute") oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.DEFAULTS) End Sub ' _ShellExecute V0.8.5