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