0bb042d442
+ workaround for setPosSize issue (LO 4.1) + "Sidebar" argument for RunCommand + Trace dialog layout revisit for cleaner display in Linux Change-Id: I0d5c4da5681ab1649d062a7133d507163163343e Reviewed-on: https://gerrit.libreoffice.org/6449 Reviewed-by: Lionel Elie Mamane <lionel@mamane.lu> Tested-by: Lionel Elie Mamane <lionel@mamane.lu>
2046 lines
92 KiB
XML
2046 lines
92 KiB
XML
<?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
|
|
|
|
'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
|
|
</script:module> |