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 'Global _gFind As _FindParams Type _Window Frame As Object ' com.sun.star.comp.framework.Frame _Name As String ' Object Name WindowType As Integer ' One of the object types 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 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 Utils._SetCalledSub("Close") 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 If _TraceStandalone() Then Goto Exit_Function ' Check existence of object and find its exact (case-sensitive) name Set oDatabase = Application._CurrentDb() Select Case pvObjectType Case acForm sObjects = oDatabase.Document.getFormDocuments.ElementNames() 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.getByName(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("Close") 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 End Function ' (m)Close 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 oFindRecord = Application.CurrentDb().FindRecord With oFindRecord If .FindRecord = 0 Then Goto Error_FindRecord .FindRecord = 0 Set ofForm = getObject(.Form) 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 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 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 V0.9.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 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 Application.CurrentDb().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 V0.9.1 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, Utils._SetCalledSub("GoToControl") If _ErrorHandler() Then On Local Error Goto Error_Function 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 in the object designated by pvObjectType (MUST BE acDataForm) If _ErrorHandler() Then On Local Error Goto Error_Function GoToRecord = False Utils._SetCalledSub("GoToRecord") If IsMissing(pvObjectName) Then pvObjectName = "" If IsMissing(pvObjectType) Then If pvObjectName <> "" Then pvObjectType = acDataForm Else pvObjectType = acActiveDataObject End If If IsMissing(pvRecord) Then pvRecord = acNext If IsMissing(pvOffset) Then pvOffset = 1 If Not (Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric() _ , Array(acActiveDataObject, acDataForm)) _ 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 Dim i As Integer, iCount As Integer, bFound As Boolean, lOffset As Long Dim sObjectName, iLengthName As Integer Select Case pvObjectType Case acActiveDataObject ' Determine active form iCount = Application._CountOpenForms() If iCount = 0 Then Goto Error_ActiveForm bFound = False For i = 0 To iCount - 1 ' Determine form having the focus Set ofForm = Application.Forms(i) If ofForm.Component.CurrentController.Frame.IsActive() Then bFound = True Exit For End If Next i If Not bFound Then Goto Error_ActiveForm 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 Case Else ' Not supported End Select ' Check if current row updated => Save it Dim oResultSet As Object Set oResultSet = ofForm.DatabaseForm 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("GoToRecord") Exit Function Error_Function: TraceError(TRACEABORT, Err, "GoToRecord", Erl) GoTo Exit_Function Error_ActiveForm: TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0) Goto Exit_Function Error_Target: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 2) Goto Exit_Function Error_Offset: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 4) 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 pvRight As Variant _ , ByVal Optional pvDown As Variant _ , ByVal Optional pvWidth As Variant _ , ByVal Optional pvHeight As Variant _ ) As Variant ' Execute MoveSize action Utils._SetCalledSub("MoveSize") If _ErrorHandler() Then On Local Error Goto Error_Function MoveSize = False If IsMissing(pvRight) Then pvRight = -1 If IsMissing(pvDown) Then pvDown = -1 If IsMissing(pvWidth) Then pvWidth = -1 If IsMissing(pvHeight) Then pvHeight = -1 If Not Utils._CheckArgument(pvRight, 1, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvDown, 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 ' Check argument values iArg = 0 If pvHeight < -1 Then iArg = 4 : If pvWidth < -1 Then iArg = 3 If pvDown < -1 Then iArg = 2 : If pvRight < -1 Then iArg = 2 If iArg > 0 Then TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, iArg) Goto Exit_Function End If Dim iPosSize As Integer iPosSize = 0 If pvRight >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X If pvDown >= 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(pvRight, pvDown, 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 V0.8.5 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 oOpenForm As Object, bOpenMode As Boolean, oController As Object If _TraceStandalone() Then Goto Exit_Function 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 = Application._CurrentDb().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.hasByName("MainForm") Then Set oForm = oFormsCollection.getByName("MainForm") ElseIf oFormsCollection.hasByName("Form") Then Set oForm = oFormsCollection.getByName("Form") ElseIf oFormsCollection.hasByName(ofForm._Name) Then Set oForm = oFormsCollection.getByName(ofForm._Name) Else Goto Trace_Error End If If sFilter <> "" Then oForm.Filter = Utils._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 'Housekeeping Set ofForm = Application.AllForms(pvFormName) ' Redone to reinitialize all properties of ofForm now FormName is open With ofForm Select Case pvDataMode Case acFormAdd .setAllowAdditions = 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 .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 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 ' Derived from BaseTools 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 Dim oDatabase As Object, oURL As New com.sun.star.util.URL, oDispatch As Object Dim vArgs(8) as New com.sun.star.beans.PropertyValue Set oDatabase = _CurrentDb oURL.Complete = ".component:DB/DataSourceBrowser" oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8) vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = CurrentDb.Connection vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND vArgs(2).Name = "Command" : vArgs(2).Value = Utils._ReplaceSquareBrackets(pvSQL) vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False vArgs(6).Name = "Filter" : vArgs(6).Value = "" vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough )) oDispatch.dispatch(oURL, vArgs) OpenSQL = True Exit_Function: Utils._ResetCalledSub("OpenSQL") Exit Function Error_Function: TraceError(TRACEABORT, Err, "OpenSQL", Erl) GoTo Exit_Function SQL_Error: TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) Goto Exit_Function End Function ' OpenSQL V0.9.5 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 _ ) As Boolean 'Supported: acFormatPDF, acFormatODT, acFormatDOC, acFormatHTML for forms If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OutputTo") OutputTo = False If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), 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(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 = "" If Not Utils._CheckArgument(pvEncoding, 7, vbString, "") Then Goto Exit_Function 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 <> acSendForm 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() ' 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("OutputTo") Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Object", pvObjectName)) Goto Exit_Function Error_Action: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "OutputTo", 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 Utils._SetCalledSub("Quit") If IsMissing(pvSave) Then pvSave = acQuitSaveAll If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _ Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _ ) Then Goto Exit_Function Dim vDatabase As Variant, oDoc As Object vDatabase = CurrentDb If Not IsNull(vDatabase) Then Set oDoc = vDatabase.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("Quit") Set vDatabase = Nothing Set oDoc = Nothing Exit Function Error_Function: TraceError(TRACEABORT, Err, "Quit", Erl) Set OpenForm = Nothing GoTo Exit_Function End Function ' Quit 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 ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function RunCommand(Optional pvCommand As Variant) As Boolean ' Execute command via DispatchHelper If _ErrorHandler() Then On Local Error Goto Exit_Function ' Avoid any abort Utils._SetCalledSub("RunCommand") 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 VarType(pvCommand) = vbString Then sOOCommand = pvCommand iVBACommand = -1 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) = "MORECONTROLS" : sDispatch = "MoreControls" 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 Dim oDocument As Object, oDispatcher As Object, oArgs() As new com.sun.star.beans.PropertyValue, sTargetFrameName As String Dim oResult As Variant oDocument = _SelectWindow().Frame oDispatcher = createUnoService("com.sun.star.frame.DispatchHelper") sTargetFrameName = "" oResult = oDispatcher.executeDispatch(oDocument, ".uno:" & sDispatch, sTargetFrameName, 0, oArgs()) Exit_Function: RunCommand = True Utils._ResetCalledSub("RunCommand") Exit Function Error_Function: TraceError(TRACEABORT, Err, "RunCommand", 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(), dbSQLPassThrough) Then Goto Exit_Function End If Dim oDatabase As Object, oStatement As Object, vResult As Variant Set oDatabase = _CurrentDb Set oStatement = oDatabase.Connection.createStatement() oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) On Local Error Goto SQL_Error vResult = oStatement.executeUpdate(Utils._ReplaceSquareBrackets(pvSQL)) On Local Error Goto Error_Function RunSQL = True Exit_Function: Utils._ResetCalledSub("RunSQL") Exit Function Error_Function: TraceError(TRACEABORT, Err, "RunSQL", Erl) GoTo Exit_Function SQL_Error: TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) Goto Exit_Function End Function ' RunSQL V0.7.5 REM ----------------------------------------------------------------------------------------------------------------------- Public Function SelectObject( Optional pvObjectType As Variant _ , Optional pvObjectName As Variant _ , Optional pvInDatabaseWindow As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("SelectObject") If IsMissing(pvObjectType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow) _ ) Then Goto Exit_Function If IsMissing(pvObjectName) Then Select Case pvObjectType Case acForm, acQuery, acTable, acReport : 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 oWindow.Frame.ContainerWindow.setFocus() oWindow.Frame.ContainerWindow.setEnable(True) ' Added to try to bypass desynchro issue in Linux Exit_Function: Utils._ResetCalledSub("SelectObject") Exit Function Error_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Object", pvObjectName)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "SelectObject", Erl) GoTo Exit_Function End Function ' SelectObject V0.8.5 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 = _getTempDirectoryURL() If Right(sDirectory, 1) <> "/" Then sDirectory = sDirectory & "/" If pvOutputFormat = "" Then sOutputFormat = _PromptFormat() ' 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("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 ShowAllrecords() As Boolean ' Removes any existing filter that exists on the current table, query or form Utils._SetCalledSub("ShowAllrecords") ShowAllRecords = False Dim oWindow As Object 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("ShowAllrecords") Exit Function End Function ' ShowAllrecords V0.7.5 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 ----------------------------------------------------------------------------------------------------------------------- Public Function _ConvertToURL(psFile As String) As String ' Convert psFile to URL only if necessary Dim bURL As Boolean Select Case True Case Len(psFile < 7) : bURL = False Case LCase(Left(psFile, 7)) = "file://" : bURL = True Case LCase(Left(psFile, 6)) = "ftp://" : bURL = True Case Else : bURL = False End Select If bURL Then _ConvertToURL = psFile Else _ConvertToURL = ConvertToURL(psFile) End Function REM ----------------------------------------------------------------------------------------------------------------------- Private Function _getTempDirectoryURL() As String ' Return the tempry directory defined in the OO Options (Paths) Dim sDirectory As String, oSettings As Object, oPathSettings As Object If _ErrorHandler() Then On Local Error Goto Error_Function _getTempDirectoryURL = "" oPathSettings = createUnoService( "com.sun.star.util.PathSettings" ) sDirectory = oPathSettings.GetPropertyValue( "Temp" ) _getTempDirectoryURL = sDirectory Exit_Function: Exit Function Error_Function: TraceError("ERROR", Err, "_getTempDirectoryURL", Erl) _getTempDirectoryURL = "" Goto Exit_Function End Function ' _getTempDirectoryURL V0.8.5 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 ----------------------------------------------------------------------------------------------------------------------- Public Function _MakePropertyValue(ByVal Optional psName As String, ByVal Optional pvValue As Variant) As com.sun.star.beans.PropertyValue 'Build PropertyValue(s) array Dim oPropertyValue As New com.sun.star.beans.PropertyValue If Not IsMissing(psName) Then oPropertyValue.Name = psName If Not IsMissing(pvValue) Then oPropertyValue.Value = pvValue _MakePropertyValue() = oPropertyValue End Function ' _MakePropertyValue 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 If _TraceStandalone() 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() ' 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 Set oController = oDatabase.Document.CurrentController Set oObject = oController.loadComponent(lComponent, sObjectName, ( pvView = acViewDesign )) _OpenObject = True Exit_Function: Set oObject = 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 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() As String ' Return user selection in Format dialog Dim oDialog As Object, oDialogLib As Object, iOKCancel As Integer, oControl As Object Set oDialogLib = DialogLibraries If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") Set oDialog = CreateUnoDialog(DialogLibraries.Access2Base.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") iOKCancel = oDialog.Execute() Select Case iOKCancel Case 1 ' OK _PromptFormat = oDialog.Model.getByName("cboFormat").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, bValid As Boolean, sName As String, iType As Integer Dim sImplementation As String Dim oWindow As _Window If _ErrorHandler() Then On Local Error Goto Error_Function bActive = IsMissing(piWindowType) Set oWindow.Frame = Nothing If bActive Then oWindow.WindowType = -1 oWindow._Name = "" Else oWindow.WindowType = piWindowType Select Case piWindowType Case acBasicIDE, acDatabaseWindow : oWindow._Name = "" Case Else : oWindow._Name = psWindow End Select End If Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") Set oEnum = oDesk.Components().createEnumeration Do While oEnum.hasMoreElements 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" bValid = True 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" ' Potential standalone form If Not IsNull(CurrentDb(oComp.URL)) Then iType = acForm Else bValid = False Case Else bValid = False ' Ignore other Writer documents End Select If bValid Then For i = 0 To UBound(oComp.Args()) If oComp.Args(i).Name = "DocumentTitle" Or oComp.Args(i).Name = "Title" Then ' Title for standalone forms sName = oComp.Args(i).Value Exit For End If Next i Set oFrame = oComp.CurrentController.Frame End If 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 Else ' Ignore other Calc, ..., whatever documents Set oFrame = Nothing 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 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 V0.9.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, sSubject As String, sBody As String, oDispatch As Object Const cstComma = "," Const cstSpace = "%20" Const cstCR = "%0A" 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 = "" If psSubject <> "" Then sSubject = Join(Split(psSubject, " "), cstSpace) Else sSubject = "" If psBody <> "" Then sBody = Join(Split(psBody, Chr(13)), cstCR) sBody = Join(Split(sBody, " "), cstSpace) End If sMailTo = "mailto:" _ & sTo & "?" _ & Iif(sCc = "", "", "cc=" & sCc & "&") _ & Iif(sBcc = "", "", "bcc=" & sBcc & "&") _ & Iif(sSubject = "", "", "subject=" & sSubject & "&") _ & Iif(sBody = "", "", "body=" & sBody & "&") If Right(sMailTo, 1) = "&" Or Right(sMailTo, 1) = "?" Then sMailTo = Left(sMailTo, Len(sMailTo) - 1) oDispatch = createUnoService( "com.sun.star.frame.DispatchHelper") oDispatch.executeDispatch(StarDesktop, sMailTo, "", 0, Array()) _SendWithoutAttachment = True Exit_Function: Exit Function Error_Function: TraceError(TRACEABORT, Err, "_SendWithoutAttachments", Erl) _SendWithoutAttachment = False Goto Exit_Function End Function ' _SendWithoutAttachment V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- Private Sub _ShellExecute(sCommand As String) ' Execute shell command Dim oShell As Object Set oShell = createUnoService("com.sun.star.system.SystemShellExecute") oShell.execute(sCommand, "" , com.sun.star.system.SystemShellExecuteFlags.DEFAULTS) End Sub ' _ShellExecute V0.8.5