diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 09:06:44 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 09:06:44 +0000 |
| commit | ed5640d8b587fbcfed7dd7967f3de04b37a76f26 (patch) | |
| tree | 7a5f7c6c9d02226d7471cb3cc8fbbf631b415303 /wizards/source/access2base/DoCmd.xba | |
| parent | Initial commit. (diff) | |
| download | libreoffice-upstream.tar.xz libreoffice-upstream.zip | |
Adding upstream version 4:7.4.7.upstream/4%7.4.7upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/access2base/DoCmd.xba | 2662 |
1 files changed, 2662 insertions, 0 deletions
diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba new file mode 100644 index 000000000..ded67fe59 --- /dev/null +++ b/wizards/source/access2base/DoCmd.xba @@ -0,0 +1,2662 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="DoCmd" script:language="StarBasic"> +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.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#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.URIS_ONLY) + +End Sub ' _ShellExecute V0.8.5 + +</script:module>
\ No newline at end of file |