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